Moose-2.1005000755000767000024 012200352344 12253 5ustar00etherstaff000000000000TODO100644000767000024 4552612200352344 13060 0ustar00etherstaff000000000000Moose-2.1005# vim: set ft=markdown : ## Uncontroversial Items These items are reasonably well thought out, and can go in any major release. ### RT Tickets RT#59478/RT#63000 - 0+ overload causes NV conversion on == on perls before 5.14 - this causes comparisons to fail when the number can't fit in an NV without precision loss. I'd like to fix this in a more general way (forcing anyone else who might be using == on tc objects to do weird things isn't very good), although it's hard to test to see what actually works. ### Revise MetaRole API to reunify class/role metaroles: apply_metaroles( for => $meta, roles => { attribute => [...], class => [...], role_attribute => [ ... ], } ); If the $meta is a class, we apply the roles to the class. If it's a role, we hold onto them and apply them as part of applying the role to a class. To make this all work nicely, we'll probably want to track the original role where a method was defined, just like we do with attributes currently. We'll also need to store method modifiers with their original role, which may mean adding some sort of Moose::Meta::Role::MethodModifier class. For each role-specific thing (methods, attributes, etc.) we should allow a `role_attribute`, `role_method`, etc. key. The common case will be that the metaroles are intended for the consuming class, but we should allow for metaroles on the role's metaobjects as well. ### Deprecate old-style Moose extensions Moose extensions that work by calling `Moose->init_meta(metaclass => 'Some::Custom::Metaclass', ...)` during their own `init_meta` should be deprecated, so they can be removed later (this should fix the issues with `init_meta` generation in Moose::Exporter, see RT51561) This needs to wait until the previous fix gets in, since it will hopefully eliminate the need to write custom `init_meta` methods entirely. ### Attributes in roles need to be able to participate in role composition Right now, this fails with no decent workaround: package R1; use Moose::Role; has foo => (is => 'ro'); package R2; use Moose::Role; with 'R1'; requires 'foo'; package C; use Moose; with 'R2'; Role attributes really need to be able to participate in role-role combination. This should also fix "with 'Role1', 'Role2'" being broken when Role1 implements a method as an accessor and Role2 requires that method, but at least in that case you can split it into two 'with' statements with minimal loss of functionality. ### Method modifiers in roles should silently add 'requires' for them This shouldn't be a functionality change, just a better error message (and better introspectability). This shouldn't happen if the role already contains a method by that name, so it'll depend on the previous fix going in (so "has foo => (is => 'ro'); around foo => sub { }" doesn't produce a 'requires' entry). ### has +foo in roles There's no actual reason for this not to work, and it gets asked often enough that we really should just do it at some point. ### use Sub::Identify instead of doing our own thing with `get_code_info` No idea why we stopped using Sub::Identify in the past, but there's no reason not to do this. We have a bug fix in our version (the `isGV_with_GP` thing), so this should be submitted to Sub::Identify first. ## Needs Thought These are things we think are good ideas, but they need more fleshing out. ### Add overloading support or at least, don't break existing overloading support This shouldn't treat the overloading stuff as actual methods, since that's just an implementation detail, but we should provide an API for `add_overload`, `get_overload`, `get_overload_list`, etc. In particular, this would allow namespace::autoclean to not break things. Also, MooseX::Role::WithOverloading should probably be cored. This should probably also wait for the metarole unification fix, to avoid the ::WithOverloading stuff being too insane. ### Actual API for metaclass extensions Right now, the only way to bundle multiple metaclass traits is via Moose::Exporter. This is unhelpful if you want to apply the extension to a metaclass object rather than a class you're actually writing. We should come up with an API for doing this. ### MooseX::NonMoose in core I think all of the actual issues are solved at this point. The only issue is the (necessary) implementation weirdness - it sets up multiple inheritance between the non-Moose class and Moose::Object, and it installs a custom constructor method at 'extends' time (although perhaps this could be solved by moving some of the logic back into Moose::Object::new?). Other than that, it handles everything transparently as far as I can tell. ### Fix attribute and method metaclass compatibility So i got this wrong when rewriting it last year - right now, metaclass compat checks the default attribute and method metaclasses, which is wrong. This means that if a parent class does "use MooseX::FollowPBP", then attributes declared in a subclass will get PBP-style accessors, which is quite surprising. On the other hand, sometimes metaclasses might need to be able to say "I'm going to assume that all of my attributes at least inherit from this custom class", so we might need to split it into "default specified by the user" and "default specified by the metaclass" and only do compat checking on the second? I'm not actually sure this is a valid use case though. Something that probably should be taken into account though is attributes and methods that extend existing attributes or methods from a superclass should inherit the metaclass of the existing one. Also not sure if this is correct, but something to think about. ### Rename a bunch of the public API methods Right now the public API is kind of a mess - we have things like `get_method` vs `find_method_by_name` (you almost always want to use the latter), there being no `has_method` equivalent that checks superclasses, `get_method_list` being public but only returning method names, while `_get_local_methods` is private (returning method objects), and yet neither of those looks at superclasses, and basically none of this naming follows any kind of consistent pattern. What we really need is a consistent and easy to remember API where the method that people would think to use first is the method that they actually mean. Something like renaming `find_method_by_name` to `find_method`, and `get_method` to `find_local_method` or something along those lines. ### Clean up metaclass constructors There's a _lot_ of different conventions in here. Some things to consider: * `new` vs `_new` * allowing new( 'name', %args ) vs ( name => 'name', %args ) * `Method->wrap` vs `Method->new` ### Move method modifiers out to an external module Class::Method::Modifiers uses a different method for doing method modifiers, which I'm not sure why we aren't using in Moose right now. Optionally using Class::Method::Modifiers::Fast would be even better - it uses Data::Util to implement XS method modifiers, which could help things a lot. ### Move type constraints out to an external module There's nothing about our type constraint system that requires being tied to Moose - it's conceptually an entirely separate system that Moose just happens to use. Splitting it out into its own thing (that Moose could extend to add things like role types) would make things conceptually a lot cleaner, and would let people interested in just the type system have that. ### Merge Class::MOP and Moose This is a long term goal, but would allow for a lot of things to be cleaned up. There's a bunch of stuff that's duplicated, and other stuff that's not implemented as well as it could be (Class::MOP::Method::Wrapped should be a role, for instance). ### Fix the error system oh god it's terrible More specifically, we really want exception objects. ### Moose::Util::TypeConstraints vs Moose::Meta::Type{Coercion,Constraint} The Util module has _way_ too much functionality. It needs to be refactored so it's a thin sugar layer on top of the meta API. As it stands now, it does things like parse type names (and determine if they're valid), manage the registry, and much more. ### Anything with a \_(meta)?class method Every method that returns a class name needs to become a rw attribute that can be set via the constructor. ## Things to contemplate These are ideas we're not sure about. Prototypes are welcome, but we may never merge the feature. ### Does applying metaroles really need to reinitialize the metaclass? Seems like the logic that's actually necessary is already contained in `rebless_instance`, and not reinitializing means that existing attributes and methods won't be blown away when metaroles are applied. ### Do we want to core namespace::autoclean behavior somehow? This would add Variable::Magic as a required XS dep (not a huge deal at the moment, since Sub::Name is also a required XS dep, but it'd be nice for Moose to be able to be pure perl again at some point in the future, and I'm not sure what the relative chances of Sub::Name vs Variable::Magic making it into core are). If we enabled it by default, this would also break things for people who have introduced Moose into legacy-ish systems where roles are faked using exporters (since those imported methods would be cleaned). If we decide we want this, we may want to core it as an option first ("use Moose -clean" or so), and move to making it the default later. ### Should using -excludes with a role add 'requires' for excluded methods? It seems to make sense, since otherwise you're violating the role's API contract. ### Moose "strict" mode use Moose 'strict'; This would allow us to have all sort of expensive tests which can be turned off in prod. ### Moose::Philosophy.pod To explain Moose from a very high level ### moosedoc We certainly have enough meta-information to make pretty complete POD docs. ## TODO test summary Note that some of these are fairly old, and may not be things we actually want to do anymore. ### `t/basics/basic_class_setup.t` Imports aren't automatically cleaned. Need to think about bringing namespace::autoclean functionality into core. ### `t/bugs/create_anon_recursion.t` Loading Moose::Meta::Class (or probably a lot of other metaclasses) before loading Moose or Class::MOP causes issues (the bootstrapping gets confused). ### `t/bugs/handles_foreign_class_bug.t` There should be a warning when delegated methods override 'new' (and possibly others?). ### `t/bugs/role_caller.t` Role methods should be cloned into classes on composition so that using caller(0) in a role method uses the class's package, not the role's. ### `t/cmop/metaclass_incompatibility.t` If a child class is created before a parent class, metaclass compatibility checks won't run on the child when the parent is created, and so the child could end up with an incompatible metaclass. ### `t/cmop/modify_parent_method.t` Modifying parent class methods after a child class has already wrapped them with a method modifier will cause the child class method to retain the original method that it wrapped, not the new one it was replaced with. ### `t/immutable/inline_close_over.t` Initializers and custom error classes still close over metaobjects. Initializers do it because the initializer has to be passed in the attribute metaobject as a parameter, and custom error classes can't be automatically inlined. ### `t/metaclasses/moose_exporter_trait_aliases.t` Renamed imports aren't cleaned on unimport. For instance: package Foo; use Moose has => { -as => 'my_has' }; no Moose; # Foo still contains my_has ### `t/metaclasses/reinitialize.t` Special method types can't have method metaroles applied. Applying a method metarole to a class doesn't apply that role to things like constructors, accessors, etc. ### `t/roles/compose_overloading.t` Overload methods aren't composed during role composition (this is detailed above - Add overloading support). ### `t/roles/method_modifiers.t` Method modifiers in roles don't support the regex form of method selection. ### `t/roles/role_compose_requires.t` Accessors for attributes defined in roles don't satisfy role method requirements (this is detailed above - Attributes in roles need to be able to participate in role composition). ### `t/todo_tests/exception_reflects_failed_constraint.t` Type constraint failures should indicate which ancestor constraint failed - subtype 'Foo', as 'Str', where { length < 5 } should mention Str when passed an arrayref, but not when passed the string "ArrayRef". ### `t/todo_tests/moose_and_threads.t` On 5.8, the type constraint name parser isn't thread safe. ### `t/todo_tests/replacing_super_methods.t` Modifying parent class methods after a child class has already wrapped them with a override will cause 'super' in the child class to call the original parent class method, not the one it was overridden with. ### `t/todo_tests/required_role_accessors.t` Role attribute accessors don't satisfy requires from roles they consume. ### `t/todo_tests/role_insertion_order.t` Roles don't preserve attribute `insertion_order`. ### `t/todo_tests/various_role_features.t` * Role attribute accessors don't satisfy requires from roles they consume. * Role combination should produce a conflict when one role has an actual method and the other role has an accessor. * Role attribute accessors should not override methods in the class the role is applied to. * Role attribute accessors should be delegated when a class does handles => 'Role'. * Delegating to a role doesn't make $class->does('Role') true. * Method modifier in a role doesn't create a method requirement. * `Role->meta->has_method('attr_accessor')` is false. ### `t/type_constraints/type_names.t` Type constraint object constructors don't validate the type name provided. ### MooseX::Aliases in core Is there any reason why this would be bad? It would certainly make the implementation a little faster (it can be inlined better). ### MooseX::MethodAttributes in core discuss ---- ## Old todo Old todo stuff which may be totally out of date. ### DDuncan's Str types subtype 'Str' => as 'Value' => where { Encode::is_utf8( $_[0] ) or $_[0] !~ m/[^0x00-0x7F]/x } => optimize_as { defined($_[0]) && !ref($_[0]) }; subtype 'Blob' => as 'Value' => where { !Encode::is_utf8( $_[0] ) } => optimize_as { defined($_[0]) && !ref($_[0]) }; ### type unions Add support for doing it with Classes which do not have a type constraint yet created ### type intersections Mostly just for Roles KENTNL is working on this ### inherited slot specs 'does' can be added to,.. but not changed (need type unions for this) ### proxy attributes a proxied attribute is an attribute which looks like an attribute, talks like an attribute, smells like an attribute,.. but if you look behind the curtain,.. its over there.. in that other object (... probably be a custom metaclass) ### local coerce [13:16] mst stevan: slight problem with coerce [13:16] mst I only get to declare it once [13:17] mst so if I'm trying to declare it cast-style per-source-class rather than per-target-class [13:17] mst I am extremely screwed [13:17] stevan yes [13:17] stevan they are not class specific [13:18] stevan they are attached to the type constraint itself [13:18] * stevan ponders anon-coercion-metaobjects [13:18] mst yes, that's fine [13:19] mst but when I declare a class [13:19] mst I want to be able to say "this class coerces to X type via " [13:19] stevan yeah something like that [13:19] stevan oh,.. hmm [13:20] stevan sort of like inflate/deflate? [13:20] stevan around the accessors? [13:25] * bluefeet has quit (Remote host closed the connection) [13:27] mst no [13:27] mst nothing like that [13:27] mst like a cast [13:31] mst stevan: $obj->foo($bar); where 'foo' expects a 'Foo' object [13:31] mst stevan: is effectively $bar, right? [13:32] mst stevan: I want to be able to say in package Bar [13:32] mst stevan: coerce_to 'Foo' via { ... }; [13:32] mst etc. [13:53] stevan hmm ### add support for locally scoped TC This would borrow from MooseX::TypeLibrary to prefix the TC with the name of the package. It would then be accesible from the outside as the fully scoped name, but the local attributes would use it first. (this would need support in the registry for this). ### look into sugar extensions Use roles as sugar layer function providers (ala MooseX::AttributeHelpers). This would allow custom metaclasses to provide roles to extend the sugar syntax with. (NOTE: Talk to phaylon a bit more on this) ### allow a switch of some kind to optionally turn TC checking off at runtime The type checks can get expensive and some people have suggested that allowing the checks to be turned off would be helpful for deploying into performance intensive systems. Perhaps this can actually be done as an option to `make_immutable`? ### misc. minor bits * make the errors for TCs use `->message` * look into localizing the messages too * make ANON TCs be lazy, so they can possibly be subsituted for the real thing later * make ANON TCs more introspectable * add this ... subtype 'Username', from 'Str', where { (/[a-z][a-z0-9]+/i or fail('Invalid character(s)')) and (length($_) >= 5 or fail('Too short (less than 5 chars)')) } on_fail { MyException->throw(value => $_[0], message => $_[1]) }; fail() will just return false unless the call is made via `$tc->check_or_fail($value);` * and then something like this: subtype Foo => as Bar => where { ... } => scoped => -global; subtype Foo => as Bar => where { ... } => scoped => -local; # or subtype Foo => as Bar => where { ... } => in __PACKAGE__ ; # or (not sure if it would be possible) my $Foo = subtype Bar => where { ... }; ### Deep coercion? [17:10] stevan: it should do it if I pass coerce => 1 as part of the attribute definition [17:12] autarch: what I am not 100% sure of is how to tell it to deep coerce and when to not [17:13] cause a basic coerce is from A to B [17:13] hmm [17:13] which is valid for collection types too [17:13] deep coercion is what you are asking for [17:13] yeah [17:13] so perhaps we add deep_coerce => 1 [17:13] which will do it [17:13] that's fine for me [17:13] k `coerce_deeply => 1 # reads better` ### Moose::Meta::TypeConstraint::Parameter{izable,ized} The relationship between these two classes is very odd. In particular, this line in Parameterized is insane: foreach my $type (Moose::Util::TypeConstraints::get_all_parameterizable_types()) { Why does it need to loop through all parameterizable types? Shouldn't it know which parameterizable type it "came from"? mop.c100644000767000024 1634212200352344 13321 0ustar00etherstaff000000000000Moose-2.1005#include "mop.h" void mop_call_xs (pTHX_ XSPROTO(subaddr), CV *cv, SV **mark) { dSP; PUSHMARK(mark); (*subaddr)(aTHX_ cv); PUTBACK; } #if PERL_VERSION >= 10 UV mop_check_package_cache_flag (pTHX_ HV *stash) { assert(SvTYPE(stash) == SVt_PVHV); /* here we're trying to implement a c version of mro::get_pkg_gen($stash), * however the perl core doesn't make it easy for us. It doesn't provide an * api that just does what we want. * * However, we know that the information we want is, inside the core, * available using HvMROMETA(stash)->pkg_gen. Unfortunately, although the * HvMROMETA macro is public, it is implemented using Perl_mro_meta_init, * which is not public and only available inside the core, as the mro * interface as well as the structure returned by mro_meta_init isn't * considered to be stable yet. * * Perl_mro_meta_init isn't declared static, so we could just define it * ourselfs if perls headers don't do that for us, except that won't work * on platforms where symbols need to be explicitly exported when linking * shared libraries. * * So our, hopefully temporary, solution is to be even more evil and * basically reimplement HvMROMETA in a very fragile way that'll blow up * when the relevant parts of the mro implementation in core change. * * :-( * */ return HvAUX(stash)->xhv_mro_meta ? HvAUX(stash)->xhv_mro_meta->pkg_gen : 0; } #else /* pre 5.10.0 */ UV mop_check_package_cache_flag (pTHX_ HV *stash) { PERL_UNUSED_ARG(stash); assert(SvTYPE(stash) == SVt_PVHV); return PL_sub_generation; } #endif SV * mop_call0 (pTHX_ SV *const self, SV *const method) { dSP; SV *ret; PUSHMARK(SP); XPUSHs(self); PUTBACK; call_sv(method, G_SCALAR | G_METHOD); SPAGAIN; ret = POPs; PUTBACK; return ret; } int mop_get_code_info (SV *coderef, char **pkg, char **name) { if (!SvOK(coderef) || !SvROK(coderef) || SvTYPE(SvRV(coderef)) != SVt_PVCV) { return 0; } coderef = SvRV(coderef); /* sub is still being compiled */ if (!CvGV(coderef)) { return 0; } /* I think this only gets triggered with a mangled coderef, but if we hit it without the guard, we segfault. The slightly odd return value strikes me as an improvement (mst) */ if ( isGV_with_GP(CvGV(coderef)) ) { GV *gv = CvGV(coderef); HV *stash = GvSTASH(gv) ? GvSTASH(gv) : CvSTASH(coderef); *pkg = stash ? HvNAME(stash) : "__UNKNOWN__"; *name = GvNAME( CvGV(coderef) ); } else { *pkg = "__UNKNOWN__"; *name = "__ANON__"; } return 1; } /* XXX: eventually this should just use the implementation in Package::Stash */ void mop_get_package_symbols (HV *stash, type_filter_t filter, get_package_symbols_cb_t cb, void *ud) { HE *he; (void)hv_iterinit(stash); if (filter == TYPE_FILTER_NONE) { while ( (he = hv_iternext(stash)) ) { STRLEN keylen; const char *key = HePV(he, keylen); if (!cb(key, keylen, HeVAL(he), ud)) { return; } } return; } while ( (he = hv_iternext(stash)) ) { GV * const gv = (GV*)HeVAL(he); STRLEN keylen; const char * const key = HePV(he, keylen); SV *sv = NULL; if(isGV(gv)){ switch (filter) { case TYPE_FILTER_CODE: sv = (SV *)GvCVu(gv); break; case TYPE_FILTER_ARRAY: sv = (SV *)GvAV(gv); break; case TYPE_FILTER_IO: sv = (SV *)GvIO(gv); break; case TYPE_FILTER_HASH: sv = (SV *)GvHV(gv); break; case TYPE_FILTER_SCALAR: sv = (SV *)GvSV(gv); break; default: croak("Unknown type"); } } /* expand the gv into a real typeglob if it * contains stub functions or constants and we * were asked to return CODE references */ else if (filter == TYPE_FILTER_CODE) { gv_init(gv, stash, key, keylen, GV_ADDMULTI); sv = (SV *)GvCV(gv); } if (sv) { if (!cb(key, keylen, sv, ud)) { return; } } } } static bool collect_all_symbols (const char *key, STRLEN keylen, SV *val, void *ud) { HV *hash = (HV *)ud; if (!hv_store (hash, key, keylen, newRV_inc(val), 0)) { croak("failed to store symbol ref"); } return TRUE; } HV * mop_get_all_package_symbols (HV *stash, type_filter_t filter) { HV *ret = newHV (); mop_get_package_symbols (stash, filter, collect_all_symbols, ret); return ret; } #define DECLARE_KEY(name) { #name, #name, NULL, 0 } #define DECLARE_KEY_WITH_VALUE(name, value) { #name, value, NULL, 0 } /* the order of these has to match with those in mop.h */ static struct { const char *name; const char *value; SV *key; U32 hash; } prehashed_keys[key_last] = { DECLARE_KEY(_expected_method_class), DECLARE_KEY(ISA), DECLARE_KEY(VERSION), DECLARE_KEY(accessor), DECLARE_KEY(associated_class), DECLARE_KEY(associated_metaclass), DECLARE_KEY(associated_methods), DECLARE_KEY(attribute_metaclass), DECLARE_KEY(attributes), DECLARE_KEY(body), DECLARE_KEY(builder), DECLARE_KEY(clearer), DECLARE_KEY(constructor_class), DECLARE_KEY(constructor_name), DECLARE_KEY(definition_context), DECLARE_KEY(destructor_class), DECLARE_KEY(immutable_trait), DECLARE_KEY(init_arg), DECLARE_KEY(initializer), DECLARE_KEY(insertion_order), DECLARE_KEY(instance_metaclass), DECLARE_KEY(is_inline), DECLARE_KEY(method_metaclass), DECLARE_KEY(methods), DECLARE_KEY(name), DECLARE_KEY(package), DECLARE_KEY(package_name), DECLARE_KEY(predicate), DECLARE_KEY(reader), DECLARE_KEY(wrapped_method_metaclass), DECLARE_KEY(writer), DECLARE_KEY_WITH_VALUE(package_cache_flag, "_package_cache_flag"), DECLARE_KEY_WITH_VALUE(_version, "-version"), DECLARE_KEY(operator) }; SV * mop_prehashed_key_for (mop_prehashed_key_t key) { return prehashed_keys[key].key; } U32 mop_prehashed_hash_for (mop_prehashed_key_t key) { return prehashed_keys[key].hash; } void mop_prehash_keys () { int i; for (i = 0; i < key_last; i++) { const char *value = prehashed_keys[i].value; prehashed_keys[i].key = newSVpv(value, strlen(value)); PERL_HASH(prehashed_keys[i].hash, value, strlen(value)); } } XS_EXTERNAL(mop_xs_simple_reader) { #ifdef dVAR dVAR; dXSARGS; #else dXSARGS; #endif register HE *he; mop_prehashed_key_t key = (mop_prehashed_key_t)CvXSUBANY(cv).any_i32; SV *self; if (items != 1) { croak("expected exactly one argument"); } self = ST(0); if (!SvROK(self)) { croak("can't call %s as a class method", prehashed_keys[key].name); } if (SvTYPE(SvRV(self)) != SVt_PVHV) { croak("object is not a hashref"); } if ((he = hv_fetch_ent((HV *)SvRV(self), prehashed_keys[key].key, 0, prehashed_keys[key].hash))) { ST(0) = HeVAL(he); } else { ST(0) = &PL_sv_undef; } XSRETURN(1); } mop.h100644000767000024 554512200352344 13311 0ustar00etherstaff000000000000Moose-2.1005#ifndef __MOP_H__ #define __MOP_H__ #include "EXTERN.h" #include "perl.h" #include "XSUB.h" #define NEED_newRV_noinc #define NEED_sv_2pv_flags #define NEED_sv_2pv_nolen #include "ppport.h" /* In theory, ExtUtils::ParseXS provide backcompat for this. However, the only * available version doing that right now is 3.03_02, which is a dev release. We * don't want to depend on dev releases, so we copy the code here. It should be * removed once there's a stable ExtUtils::ParseXS version newer than 3.03_02. */ #ifndef XS_EXTERNAL # define XS_EXTERNAL XS #endif #define MOP_CALL_BOOT(name) mop_call_xs(aTHX_ name, cv, mark); #ifndef XSPROTO #define XSPROTO(name) XS_EXTERNAL(name) #endif #ifndef CvISXSUB #define CvISXSUB(cv) (CvXSUB(cv) ? TRUE : FALSE) #endif void mop_call_xs (pTHX_ XSPROTO(subaddr), CV *cv, SV **mark); typedef enum { KEY__expected_method_class, KEY_ISA, KEY_VERSION, KEY_accessor, KEY_associated_class, KEY_associated_metaclass, KEY_associated_methods, KEY_attribute_metaclass, KEY_attributes, KEY_body, KEY_builder, KEY_clearer, KEY_constructor_class, KEY_constructor_name, KEY_definition_context, KEY_destructor_class, KEY_immutable_trait, KEY_init_arg, KEY_initializer, KEY_insertion_order, KEY_instance_metaclass, KEY_is_inline, KEY_method_metaclass, KEY_methods, KEY_name, KEY_package, KEY_package_name, KEY_predicate, KEY_reader, KEY_wrapped_method_metaclass, KEY_writer, KEY_package_cache_flag, KEY__version, KEY_operator, key_last, } mop_prehashed_key_t; #define KEY_FOR(name) mop_prehashed_key_for(KEY_ ##name) #define HASH_FOR(name) mop_prehashed_hash_for(KEY_ ##name) void mop_prehash_keys (void); SV *mop_prehashed_key_for (mop_prehashed_key_t key); U32 mop_prehashed_hash_for (mop_prehashed_key_t key); #define INSTALL_SIMPLE_READER(klass, name) INSTALL_SIMPLE_READER_WITH_KEY(klass, name, name) #define INSTALL_SIMPLE_READER_WITH_KEY(klass, name, key) \ { \ CV *cv = newXS("Class::MOP::" #klass "::" #name, mop_xs_simple_reader, __FILE__); \ CvXSUBANY(cv).any_i32 = KEY_ ##key; \ } XS_EXTERNAL(mop_xs_simple_reader); extern SV *mop_method_metaclass; extern SV *mop_associated_metaclass; extern SV *mop_wrap; UV mop_check_package_cache_flag(pTHX_ HV *stash); int mop_get_code_info (SV *coderef, char **pkg, char **name); SV *mop_call0(pTHX_ SV *const self, SV *const method); typedef enum { TYPE_FILTER_NONE, TYPE_FILTER_CODE, TYPE_FILTER_ARRAY, TYPE_FILTER_IO, TYPE_FILTER_HASH, TYPE_FILTER_SCALAR, } type_filter_t; typedef bool (*get_package_symbols_cb_t) (const char *, STRLEN, SV *, void *); void mop_get_package_symbols(HV *stash, type_filter_t filter, get_package_symbols_cb_t cb, void *ud); HV *mop_get_all_package_symbols (HV *stash, type_filter_t filter); #endif Changes100644000767000024 43661712200352344 13710 0ustar00etherstaff000000000000Moose-2.1005Also see Moose::Manual::Delta for more details of, and workarounds for, noteworthy changes. 2.1005 Tue, Aug 06, 2013 [ENHANCEMENTS] * add_method now accepts blessed subs (Graham Knop, PR#28) [BUG FIXES} * If a role consumed another role, we resolve method conflicts just like a class consuming a role, but when metaclass compat tried to fix up metaclass roles, we were putting all methods into one composite role and allowing methods in the metaclass roles to conflict. Now we resolve them as we should. (Jesse Luehrs, PR#27) * Some edge cases in tests with base.pm and non-existent module files are handled more strictly (see also perl RT#118561) (Graham Knop, PR#25) 2.1004 Fri, Jul 26, 2013 [BUG FIXES] * 2.1003 was released with some bad metadata, which caused the prereq test to fail. 2.1003 Fri, Jul 26, 2013 [OTHER] * Releasing 2.0901 as stable. 2.0901-TRIAL Fri, Jun 21, 2013 [ENHANCEMENTS] * The with_immutable() sub from Test::Moose now passes a boolean value to the code block containing tests indicating whether or not the classes have been made immutable. This can make for nicer test descriptions. (Dave Rolsky) * You can now use Specio types instead of Moose builtins or MooseX::Types. As a bonus, Specio types inline coercion. However, this support is still experimental (as is Specio), so use it with care. (Dave Rolsky) 2.0900-TRIAL Sun, May 26, 2013 [API CHANGES] * Fixed the Num builtin type to reject NaN, Inf, numbers with whitespace, and other questionable strings. The MooseX::Types::LaxNum distro implements the old behavior. RT#70539 (Upasana Shukla) 2.0802 Tue, May 07, 2013 [ENHANCEMENTS] * fix incompatibilities with Test::Builder 1.005+ (Karen Etheridge) * Moose::Manual::Contributing updated to reflect the change of primary repository from git.moose.perl.org to github.com 2.0801 Thu, Mar 28, 2013 [BUG FIXES] * properly apply traits at compile time (error introduced in 2.0800, RT#77974). (doy) 2.0800 Wed, Mar 27, 2013 [ENHANCEMENTS] * The super() subroutine now carps if you pass it arguments. These arguments are always ignored, but we used to ignore them silently. RT #77383. * Roles can now override methods from other roles they consume directly, without needing to manually exclude them (just like classes can). (mst) [BUG FIXES] * Fix false positive when checking for circular references for modules that use the "also" parameter with Moose::Exporter. Reported by Jon Swartz. Fixed by Matthew Wickline. RT #63818. * Fix memory leak in type unions. (Karen Etheridge) RT#83929. * Fix application of traits at compile time. (doy) RT#77974. 2.0604 Wed, Sep 19, 2012 [BUG FIXES] * Fix nonsensical error message for inlined accessors of required attributes. (doy) * Stop trying to localize a lexical (blead now throws an error for this). RT #79257, perl #114628. (sprout) [OTHER] * Depend on a version of Carp new enough to have caller_info. RT #79367. (pshangov) 2.0603 Thu, Jun 28, 2012 [BUG FIXES] * Fix test failure in blead. RT #78085. 2.0602 Mon, May 07, 2012 [BUG FIXES] * Ensure that the Moose::Exporter-generated init_meta returns the same value that it did previously. This isn't really a bug, since the return value has never been tested or documented, but since the generated init_meta is nothing more than a compatibility shim at this point, there's no reason to not make it as compatible as possible. Reported by Moritz Onken. (doy) 2.0601 Tue, May 01, 2012 [BUG FIXES] * Fix init_meta order when multiple also packages are specified (this matters when one of them is being used to actually initalize the metaclass, typically with also => 'Moose'). Reported by Randy Stauner. (doy) 2.0600 Sun, Apr 29, 2012 [OTHER] * Releasing 2.0502 as stable. 2.0502-TRIAL Wed, Apr 25, 2012 [OTHER] * The Test::DependentModules test now covers a much wider range of downstream dependents (all of them in fact, for some definition of "all"). This should allow us to track inadvertent backwards compatibility breakages much more effectively. (doy) * A few test tweaks to avoid spurious failures. (doy) 2.0501-TRIAL Tue, Apr 03, 2012 [BUG FIXES] * Avoid syntax errors on pre-5.14. (doy) 2.0500-TRIAL Tue, Apr 03, 2012 [NEW FEATURES] * Class::MOP::Class now has methods for introspecting and modifying the overloaded operators for a class. (doy) [ENHANCEMENTS] * The cookbook recipes have all been renamed. Instead of numbered recipes (Basics::Recipe1), we now have descriptive names (Basics::Point_AttributesAndSubclassing). This makes it easier for us to add and remove recipes in the future, and makes it a little easier to converse about them, since the name gives us some clue of what they contain. [BUG FIXES] * Re-declaring a class_type or role_type constraint that has already been declared now just returns the original type constraint, rather than replacing the original constraint and ergo losing any coercions that were on the original constraint. Fixes RT #73289. (t0m) * Moose::Exporter now calls init_meta methods in the correct order, when multiple levels of 'also' parameters are specified. Reported by Rocco Caputo. (doy, perigrin) * Moose::Exporter no longer generates init_meta methods in order to apply metaroles, since the metaclass itself isn't guaranteed to exist yet at that point. Metaroles are now applied at the end of import, after all user-defined init_meta methods have been called. Fixes RT #51561. (doy) * Fixed a memory leak. This occurred when creating an anonymous class. Immutabilizing an anonymous class still leaks memory due to a bug in Eval::Closure (which should hopefully be fixed soon). Based on code and bug report from Carlos Lima. RT #74650. * Fix a segfault when adding a method to a class which was defined in a package which was deleted. (doy) 2.0403 Tue, Apr 03, 2012 [OTHER] * No changes, reupload to fix indexing. 2.0402 Sat, Feb 04, 2012 [OTHER] * Minor documentation fixes. * Fix test failure on blead (test was unnecessarily strict). Reported by Nicholas Clark. (doy) 2.0401 Thu, Nov 17, 2011 [BUG FIXES] * Attributes with weak_ref now weaken their associated slot when they are initialized through a lazy default or builder. Reported by tome. (doy) 2.0400 Tue, Nov 15, 2011 [OTHER] * No changes from 2.0302 (other than a few minor documentation tweaks). 2.0302-TRIAL Wed, Nov 02, 2011 [BUG FIXES] * Fix test failure on 5.8. (Dave Rolsky) * Make make_immutable return value consistent and document it to be true. (mst) 2.0301-TRIAL Fri, Oct 21, 2011 [BUG FIXES] * Fix compilation on 5.8. Reported by ether. (doy) * A custom error class caused a warning when the class that used it was made immutable. Reported by Maroš Kollár. RT #71514. (Dave Rolsky) [ENHANCEMENTS] * The enum type will now allow single value enumerations. Previously, two or more values were required. (rjbs) 2.0300-TRIAL Fri, Sep 23, 2011 [DEPRECATIONS] * The optimize_as option for type constraints has been deprecated. Use the inline_as option to provide inlining code instead. (Dave Rolsky) [API CHANGES] * Methods to introspect a class's methods will now return methods defined in UNIVERSAL (isa, can, etc.). This also means that you can wrap these methods with method modifiers. RT #69839. Reported by Vyacheslav Matyukhin. (Dave Rolsky) * The ->parent and ->parents method for a union now return the nearest common ancestor of that union's component types. See Moose::Manual::Delta for more details. (Dave Rolsky) * The ->parents method used to return an arrayref for union types, and a list of one or more types for all other types. Now they all return lists. (Dave Rolsky) * The ->is_subtype_of and ->is_a_type_of methods have changed their behavior for union types. Previously, they returned true if any of their member types returned true for a given type. Now, all of the member types must return true. RT #67731. (Dave Rolsky) [ENHANCEMENTS] * The Moose::Exporter module now has a "meta_lookup" option when creating an importer. This allows you to specify an alternate method for determining the metaclass of a caller. This is useful for modules like MooseX::Role::Parameterized which generate new metaclasses on the fly. (sartak) * Added a Moose::Meta::Method->is_stub method. (Dave Rolsky) [BUG FIXES] * A subtype of a union type did not return the right results when you called ->is_subtype_of or ->is_a_type_of on it. This has been fixed. RT #70322. (Dave Rolsky) * An attribute accessor or delegation method can overwrite a stub method and this will no longer throw an error. Reported by Mark-Jason Dominus. RT #69988. (Dave Rolsky) * The error generated by unfulfilled method requirements during role composition now mentions how to work around imported methods not being recognized. Reported by Michael Schwern. RT #60583. (doy) * class_type and role_type will now throw errors if you attempt to use them to override existing types, just like type and subtype have always done. (doy) * Implicitly creating class or role types by using them as the 'isa' or 'does' parameter to attribute construction will now register the type. This means that it cannot later be redefined as something else. (doy) * $class_type->is_subtype_of no longer returns true if passed the name of the class that the class type represents when the class type wasn't registered. (doy) * Removing anonymous metaclasses prematurely no longer prevents reaping of the associated stash. (doy) [OTHER] * The Class::MOP::load_class and Class::MOP::is_class_loaded subroutines are no longer documented, and will cause a deprecation warning in the future. Moose now uses Class::Load to provide this functionality, and you should as well. (Dave Rolsky) 2.0205 Tue, Sep 06, 2011 [NEW FEATURES] * The Array and Hash native traits now provide a "shallow_clone" method, which will return a reference to a new container with the same contents as the attribute's reference. [ENHANCEMENTS] * Specifying an invalid value in a hashref 'handles' value now throws a sensible error. Reported by Mark-Jason Dominus. RT #69990. (Dave Rolsky) [BUG FIXES] * When specifying an attribute trait, passing options for the trait besides -alias or -excludes caused a warning. However, passing other options is totally valid when using MooseX::Role::Parameterized. Fixes RT #70419. (sartak) * Allow regexp objects in duck_type constraints (to bring this in line with the Object constraint). 2.0204 Thu, Aug 25, 2011 [BUG FIXES] * Validating duck_type type constraint turned out to work only by accident, and only when not running under the debugger. This has been fixed. (Florian Ragwitz) [OTHER] * Loosen the dependency on ExtUtils::ParseXS. 2.0203 Tue, Aug 23, 2011 [BUG FIXES] * is_class_loaded now properly detects packages which have a version object in their $VERSION. * Fix XS compilation under blead. 2.0202 Tue, Jul 26, 2011 [BUG FIXES] * Be more consistent about how type constraint messages are handled. 2.0201 Fri, Jul 22, 2011 [BUG FIXES] * Moose::Util::does_role shouldn't call ->does on things that don't inherit from Moose::Object. * Make ->does initialize the metaclass, so that calling it as a class method on a class which sets up inheritance via some method other than extends works properly (this fixes an issue with MooseX::Types). * Make Dist::CheckConflicts a runtime requirement, so moose-outdated always works. 2.0200 Mon, Jul 18, 2011 [OTHER] * No changes from 2.0105 (other than a few minor documentation tweaks). 2.0105-TRIAL Mon, Jun 27, 2011 [ENHANCEMENTS] * Moose::Util::does_role now respects overridden ->does methods. (doy) 2.0104-TRIAL Mon, Jun 20, 2011 [OTHER] * Include changes from 2.0010. 2.0103-TRIAL Mon, Jun 20, 2011 [DEPRECATIONS] * Several things that have been deprecated for a while have been removed. See the 2.0000 section in Moose::Manual::Delta for details. [NEW FEATURES] * New Moose::Util::TypeConstraints::union function for creating union type constraints without having to rely on the string type constraint parsing. This also allows for creating unions of anonymous type constraints. (kentnl) [OTHER] * Include changes from Moose 2.0009. 2.0102-TRIAL Sat, Jun 18, 2011 [ENHANCEMENTS] * The native Array trait now has a 'first_index' method, which works just like the version in List::MoreUtils. (Karen Etheridge) * Clean up some internal code to help out extensions. [OTHER] * Include changes from Moose 2.0008. 2.0101-TRIAL Mon, Jun 06, 2011 [OTHER] * Various packaging issues. 2.0100-TRIAL Mon, Jun 06, 2011 [DEPRECATIONS] * Using a hand-optimized type constraint is now deprecated. In keeping with our release policy, this won't actually start warning until the 2.0200 release. [NEW FEATURES] * Type constraints can now provide inlined versions, which should make inlined code which uses type constraints (such as accessors) faster. This replaces the existing hand-optimized constraint feature. (Dave Rolsky) [ENHANCEMENTS] * Remove a lot of cases where generated methods closed over meta objects. Most simple cases should now only close over simple data types and coderefs. This should make deparsing simpler. 2.0010 Mon, Jun 20, 2011 [BUG FIXES] * Fix regression in 2.0009 and 2.0103 when applying roles during init_meta in an exporter that also re-exports Moose or Moose::Role. (t0m, ilmari) 2.0009 Sun, Jun 19, 2011 [BUG FIXES] * duck_type type constraints now report reasonable errors when given something which isn't an instance of an object. (t0m) * Moose::Util::apply_all_roles now works even if the applicant is a non-Moose class. (perigrin) * When an object is reblessed, triggers are called on attributes that are set during the reblessing. (Karen Etheridge). [OTHER] * Better error message if Moose->init_meta is called with a 'metaclass' option when that metaclass hasn't been loaded. (jasonmay) 2.0008 Thu, Jun 16, 2011 [BUG FIXES] * The 'accessor' native delegation for hashrefs now allows setting the value to undef. (sugoik, doy) [ENHANCEMENTS] * Various generated methods have more useful context information. (doy) 2.0007 Sun, May 15, 2011 [BUG FIXES] * Make sure weak attributes remain weak when cloning. (doy, rafl) 2.0006 Mon, May 09, 2011 [BUG FIXES] * Revert the List::MoreUtils version bump, as it breaks backwards compatibility. The dependency will be bumped with Moose 2.0200. 2.0005 Mon, May 09, 2011 [BUG FIXES] * Only sort the alias keys when determining caching. 2.0004 Mon, May 09, 2011 [BUG FIXES] * Bump the List::MoreUtils dep to avoid buggy behavior in old versions. * Sort the list of roles and the alias and excludes parameters when determining caching, since their order doesn't matter. 2.0003 Mon, May 09, 2011 [BUG FIXES] * Applying multiple role objects (rather than role names) at once no longer skips every other role. (rjbs) * Caching of anon classes now works more sanely in the presence of role application parameters - alias and excludes options are taken into account, and caching is disabled entirely if other parameters exist. Asking for caching (instead of just not weakening) when parameters are given will begin warning in Moose 2.0200. (doy, autarch) 2.0002 Thu, Apr 28, 2011 [ENHANCEMENTS] * Provide definition context information for constructors and destructors, so that they will show up as something other than "generated method (unknown origin)". Also, add the package that accessors are defined in to their definition context. * Use Devel::PartialDump in type constraint error messages, if it is installed. [BUG FIXES] * Stop hiding warnings produced by throwing errors in DEMOLISH methods. * The 'reset' native delegation for Counter attributes will now also respect builders (previously, it only respected defaults). 2.0001 Fri, Apr 22, 2011 [ENHANCEMENTS] * Anonymous classes and roles now have a unified implementation in Class::MOP::Package. This means that anonymous packages are now also possible. (Shawn M Moore, doy) [BUG FIXES] * No longer call XSLoader from multiple places, as this causes issues on older perls. (doy, ribasushi) * Moose::Meta::Role->create now accepts the 'roles' parameter, as it was documented to. (Chris Weyl) * Depend on Eval::Closure 0.04, which fixes some issues in mod_perl environments. (doy, mateu) 2.0000 Mon, Apr 11, 2011 [API CHANGES] * The RegexpRef type constraint now accepts regular expressions blessed into other classes, such as those found in pluggable regexp engines. Additionally the 'Object' constraint no longer rejects objects implemented as a blessed regular expression. (David Leadbeater) [OTHER] * Moose::Manual::Support now explicitly states when major releases are allowed to happen (January, April, July, or October). 1.9906-TRIAL Mon, Apr 04, 2011 [OTHER] * Update conflicts list. * Minor pod updates. 1.9905-TRIAL Mon, Mar 28, 2011 [NEW FEATURES] * The Moose::Meta::Role::Attribute class now has an original_role method which returns the role which first defined an attribute. See the docs for details. (Dave Rolsky) * Moose::Util::MetaRole will make sure that the class to which you're applying metaroles or base class roles can actually have them applied. If not (it's not a Moose class, it has a non-Moose metaclass, etc.), then it gives a useful error message. Previously, this would just end up dying in the MetaRole code without a useful message. (Dave Rolsky) [BUG FIXES] * When a role had its own applied_attribute metaclass (usually from MetaRole application), that metaclass would get lost when that role participated in role composition. It was also lost if that role was consumed by some other role. Both of these cases have been fixed. Attributes are always applied with the applied_attribute metaclass of the role which originally defined them. (Dave Rolsky) 1.9904-TRIAL Fri, Mar 04, 2011 [BUG FIXES] * Reinitializing anonymous roles used to accidentally clear out the role's stash in some circumstances. This is now fixed. (doy) * The Int type constraint now rejects integers with trailing newlines. (Matthew Horsfall) 1.9903-TRIAL Mon, Feb 28, 2011 [BUG FIXES] * Reverse the order that Moose::Exporter 'also' exports are dispatched. When trying to re-export from a package that itself exported a modified set of Moose sugar, you'd get the original Moose sugar instead of the overrides. There are also now tests for this. (perigrin) * Don't initialize lazy attributes with defaults in the constructor (for immutable classes). (mo) * When reinitializing meta objects for classes and roles, we failed to preserve roles and role applications. This led to weird bugs. Many MooseX modules end up reinitializing your class or role. (Dave Rolsky) 1.9902-TRIAL Mon, Jan 03, 2011 [OTHER] * Fix generation of CCFLAGS. * Add a bit more Dist::Zilla functionality. 1.9901-TRIAL Mon, Jan 03, 2011 [OTHER] * Fix some indexing issues. * Fix a few issues with the conflict checking stuff. 1.9900-TRIAL Sat, Jan 01, 2011 [OTHER] * The entire Class::MOP distribution has been merged with Moose. In the future, the Class::MOP code itself will be merged into Moose, and eventually the Class::MOP namespace will disappear entirely. For the current release, we have simply changed how Class::MOP is distributed. (Dave Rolsky). * Switched to Dist::Zilla for development. However, we still have a minimal Makefile.PL in the repository that can be used for development. (Dave Rolsky) [API CHANGES] * Roles now have their own default attribute metaclass to use during application to a class, rather than just using the class's attribute_metaclass. This is also overridable via ::MetaRole, with the applied_attribute key in the role_metaroles hashref (doy). * The internal code used to generate inlined methods (accessor, constructor, etc.) has been massively rewritten. MooseX modules that do inlining will almost certainly need to be updated as well. [ENHANCEMENTS] * We now load the roles needed for native delegations only as needed. This speeds up the compilation time for Moose itself. (doy) 1.25 Fri, Apr 1, 2011 [BUG FIXES] * Reinitializing anonymous roles used to accidentally clear out the role's stash in some circumstances. This is now fixed. (doy) (backported from 1.9904) 1.24 Tue, Feb 24, 2011 [BUG FIXES] * Reverse the order that Moose::Exporter 'also' exports are dispatched. When trying to re-export from a package that itself exported a modified set of Moose sugar, you'd get the original Moose sugar instead of the overrides. There are also now tests for this. (perigrin) (backported from 1.9903) 1.23 Sun, Feb 13, 2011 [PACKAGING FIX] * The 1.22 release had a bad MANIFEST. This has been fixed. 1.22 Sun, Feb 13, 2011 [BUG FIXES] * When reinitializing meta objects for classes and roles, we failed to preserve roles and role applications. This led to weird bugs. Many MooseX modules end up reinitializing your class or role. (Dave Rolsky) (backported from 1.9903) 1.21 Wed, Nov 24, 2010 [ENHANCEMENTS] * The Support manual has been updated to reflect our new major/minor version policy. (Chris Prather) * The Contributing manual has been updated to reflect workflow changes based on this new support policy. (doy) [BUG FIXES] * The role attribute metaclass did not inherit from Class::MOP::Object, which could cause errors when trying to resolve metaclass compatibility issues. Reported by Daniel Ruoso. (doy) * The lazy_build feature was accidentally removed from all the docs. Now it's listed in Moose.pm again. (Chris Prather) 1.20 Fri, Nov 19, 2010 [BUG FIXES] * When using native delegations, if an array or hash ref member failed a type constraint check, Moose ended up erroring out with "Can't call method "get_message" on unblessed reference" instead of generating a useful error based on the failed type constraint. Reported by t0m. RT #63113. (Dave Rolsky) 1.19 Tue, Nov 2, 2010 [BUG FIXES] * There was still one place in the code trying to load Test::Exception instead of Test::Fatal. (Karen Etheridge) 1.18 Sun, Oct 31, 2010 [ENHANCEMENTS] * Type constraint objects now have an assert_coerce method which will either return a valid value or throw an error. (rjbs) * We now warn when an accessor for one attribute overwrites an accessor for another attribute. RT #57510. (Dave Rolsky) [BUG FIXES] * The native Array and Hash delegation methods now coerce individual new members if the _member type_ has a coercion. In other words, if the array reference is defined as an ArrayRef[DateTime], and you've defined a coercion from Int to DateTime, then pushing an integer via a delegation method will coerce the integer to a DateTime object. Reported by Karen Etheridge. RT #62351. (Dave Rolsky) * An attribute using native delegations did not always properly coerce and type check a lazily set default value. (doy and Dave Rolsky) * Using a regexp to define delegations for a class which was not yet loaded did not actually work, but did not explicitly fail. However, it caused an error when the class was loaded later. Reported by Max Kanat-Alexander. RT #60596. (Dave Rolsky) * Attempting to delegate to a class or role which is not yet loaded will now throw an explicit error. (Dave Rolsky) * Attempting to set lazy_build in an inherited attribute was ignored. RT #62057. (perigrin) [OTHER] * The Moose test suite now uses Test::Fatal instead of Test::Exception. (rjbs) 1.17 Tue, Oct 19, 2010 [BUG FIXES] * Make native delegation inlining work with instance metaclasses where slot access is an do {} block, like Kioku. This fixes the use of native delegations together with Kioku. (Scott, doy) 1.16 Mon, Oct 18, 2010 [ENHANCEMENTS] * Almost every native delegation method which changes the attribute value now has an explicitly documented return value. In general, this return value matches what Perl would return for the same operation. (Dave Rolsky) * Lots of work on native delegation documentation, including documenting what arguments each native delegation method allows or requires. (Dave Rolsky) * Passing an odd number of args to ->new() now gives a more useful warning than Perl's builtin warning. Suggested by Sir Robert Burbridge. (Dave Rolsky) * Allow disabling stack traces by setting an environment variable. See Moose::Error::Default for details. This feature is considered experimental, and may change in a future release. (Marcus Ramberg) * The deprecation warning for using alias and excludes without a leading dash now tells you the role being applied and what it was being applied to. (mst). [BUG FIXES] * A number of native trait methods which expected strings as arguments did not allow the empty string. This included Array->join, String->match, String->replace, and String->substr. Reported by Whitney Jackson. RT #61962. (Dave Rolsky) * 'no Moose' no longer inadvertently removes imports it didn't create itself. RT #60013. (Florian Ragwitz, doy) * Roles now support passing an array reference of method names to method modifier sugar functions. (doy) * Native traits no longer use optimized inlining routines if the instance requests it (in particular, if inline_get_slot_value doesn't return something that can be assigned to). This should fix issues with KiokuDB::Class. (doy) * We now ignore all Class::MOP and Moose classes when determining what package called a deprecated feature. This should make the deprecation warnings saner, and make it possible to turn them off more easily. (Dave Rolsky) * The deprecated "default is" warning no longer happens if the attribute has any accessor method defined (accessor, reader, writer). Also, this warning only happens when a method that was generated because of the "default is" gets called, rather than when the attribute is defined. (Dave Rolsky) * The "default default" code for some native delegations no longer issues a deprecation warning when the attribute is required or has a builder. (Dave Rolsky) * Setting a "default default" caused a fatal error if you used the builder or lazy_build options for the attribute. Reported by Kent Fredric. RT #59613. (Dave Rolsky) 1.15 Tue, Oct 5, 2010 [API CHANGES] * Major changes to Native Traits, most of which make them act more like "normal" attributes. This should be mostly compatible with existing code, but see Moose::Manual::Delta for details. * A few native traits (String, Counter, Bool) provide default values of "is" and "default" when you created an attribute. Allowing them to provide these values is now deprecated. Supply the value yourself when creating the attribute. * New option 'trait_aliases' for Moose::Exporter, which will allow you to generate non-global aliases for your traits (and allow your users to rename the aliases, etc). (doy) * 'use Moose' and 'use Moose::Role' now accept a '-meta_name' option, to determine which name to install the 'meta' name under. Passing 'undef' to this option will suppress generation of the meta method entirely. (doy) * Moose now warns if it overwrites an existing method named "meta" in your class when you "use Moose". (doy) [ENHANCEMENTS] * Native Trait delegations are now all generated as inline code. This should be much faster than the previous method of delegation. In the best case, native trait methods will be very highly optimized. * Reinitializing a metaclass no longer removes the existing method and attribute objects (it instead fixes them so they are correct for the reinitialized metaclass). This should make the order of loading many MooseX modules less of an issue. (doy) * The Moose::Manual docs have been revised and updated. (Dave Rolsky) [BUG FIXES] * If an attribute was weak, setting it to a non-ref value after the object was constructed caused an error. Now we only call weaken when the new value is a reference. * t/040_type_constraints/036_match_type_operator.t failed on 5.13.5+. Fixed based on a patch from Andreas Koenig. 1.14 Tue, Sep 21, 2010 [BUG FIXES] * Work around what looks like a bug in List::MoreUtils::any. This bug caused a weird error when defining the same union type twice, but only when using MooseX::Types. Reported by Curtis Jewell. RT #61001. (Dave Rolsky) 1.13 Mon, Sep 13, 2010 [API CHANGES] * The deprecation warnings for alias and excludes are back, use -alias and -excludes instead. (Dave Rolsky) [ENHANCEMENTS] * When composing one role into another and there is an attribute conflict, the error message now includes the attribute name. Reported by Sam Graham. RT #59985. (Dave Rolsky) * When a class is made immutable, the does_role method is overridden with a much faster version that simply looks role names up in a hash. Code which uses lots of role-based type constraints should be faster. (Dave Rolsky) 1.12 Sat, Aug 28, 2010 [BUG FIXES] * Fix the MANIFEST. Fixes RT #60831, reported by Alberto Simões. 1.11 Fri, Aug 27, 2010 [API CHANGES] * An attribute in a subclass can now override the value of "is". (doy) * The deprecation warnings for alias and excludes have been turned back off for this release, to give other module authors a chance to tweak their code. (Dave Rolsky) [BUG FIXES] * mro::get_linear_isa was being called as a function rather than a method, which caused problems with Perl 5.8.x. (t0m) * Union types always created a type constraint, even if their constituent constraints did not have any coercions. This bogus coercion always returned undef, which meant that a union which included Undef as a member always coerced bad values to undef. Reported by Eric Brine. RT #58411. (Dave Rolsky) * Union types with coercions would always fall back to coercing the value to undef (unintentionally). Now if all the coercions for a union type fail, the value returned by the coercion is the original value that we attempted to coerce. (Dave Rolsky). 1.10 Sun, Aug 22, 2010 [API CHANGES] * The long-deprecated alias and excludes options for role applications now issue a deprecation warning. Use -alias and -excludes instead. (Dave Rolsky) [BUG FIXES] * Inlined code no longer stringifies numeric attribute defaults. (vg, doy) * default => undef now works properly. (doy) * Enum type constraints now throw errors if their values are nonsensical. (Sartak) [ENHANCEMENTS] * Optimizations that should help speed up compilation time (Dave Rolsky). 1.09 Tue, Jul 25, 2010 [API CHANGES] * You can no longer pass "coerce => 1" for an attribute unless its type constraint has a coercion defined. Doing so will issue a deprecation warning. (Dave Rolsky) * Previously, '+foo' only allowed a specific set of options to be overridden, which made it impossible to change attribute options related to extensions. Now we blacklist some options, and anything else is allowed. (doy, Tuomas Jormola) * Most features which have been declared deprecated now issue a warning using Moose::Deprecated. Warnings are issued once per calling package, not repeatedly. See Moose::Deprecated for information on how you can shut these warnings up entirely. Note that deprecated features will eventually be removed, so shutting up the warnings may not be the best idea. (Dave Rolsky) * Removed the long-deprecated Moose::Meta::Role->alias_method method. (Dave Rolsky). [NEW FEATURES] * We no longer unimport strict and warnings when Moose, Moose::Role, or Moose::Exporter are unimported. Doing this was broken if the user explicitly loaded strict and warnings themself, and the results could be generally surprising. We decided that it was best to err on the side of safety and leave these on. Reported by David Wheeler. RT #58310. (Dave Rolsky) * New with_traits helper function in Moose::Util. (doy) [BUG FIXES] * Accessors will no longer be inlined if the instance metaclass isn't inlinable. (doy) * Use Perl 5.10's new recursive regex features, if possible, for the type constraint parser. (doy, nothingmuch) [ENHANCEMENTS] * Attributes now warn if their accessors overwrite a locally defined function (not just method). (doy) [OTHER] * Bump our required perl version to 5.8.3, since earlier versions fail tests and aren't easily installable/testable. 1.08 Tue, Jun 15, 2010 [ENHANCEMENTS] * Refactored a small amount of Moose::Meta::Method::Constructor to allow it to be overridden more easily (doy). 1.07 Sat, Jun 05, 2010 [BUG FIXES] * Fixed a minor metaclass compatibility fixing bug dealing with immutable classes and non-class metaclass traits (doy, dougdude). 1.06 Tue, Jun 01, 2010 [NEW FEATURES] * Added '0+' overloading in Moose::Meta::TypeConstraint so that we can more uniformly compare type constraints between 'classic' Moose type constraints and MooseX::Types based type constraints. 1.05 Thu, May 20, 2010 [API CHANGES] * Packages and modules no longer have methods - this functionality was moved back up into Moose::Meta::Class and Moose::Meta::Role individually (through the Class::MOP::Mixin::HasMethods mixin) (doy). * BUILDALL is now called by Moose::Meta::Class::new_object, rather than by Moose::Object::new. (doy) [NEW FEATURES] * strict and warnings are now unimported when Moose, Moose::Role, or Moose::Exporter are unimported. (doy, Adam Kennedy) * Added a 'consumers' method to Moose::Meta::Role for finding all classes/roles which consume the given role. (doy) [BUG FIXES] * Fix has '+attr' in Roles to explode immediately, rather than when the role is applied to a class (t0m). * Fix type constraint validation messages to not include the string 'failed' twice in the same sentence (Florian Ragwitz). * New type constraints will default to being unequal, rather than equal (rjbs). * The tests no longer check for perl's behavior of clobbering $@, which has been fixed in perl-5.13.1 (Florian Ragwitz). * Metaclass compatibility fixing has been completely rewritten, and should be much more robust. (doy) 1.04 Thu, May 20, 2010 * This release was broken and has been deleted from CPAN shortly after its upload. 1.03 Thu, May 06, 2010 [NEW FEATURES] * Allow specifying required versions when setting superclasses or applying roles (Florian Ragwitz). 1.02 Sat, May 01, 2010 [BUG FIXES] * Stop the natatime method provided by the native Array trait from returning an exhausted iterator when being called with a callback. (Florian Ragwitz) * Make Moose::Meta::TypeConstraint::Class correctly reject RegexpRefs. (Florian Ragwitz) * Calling is_subtype_of on a Moose::Meta::TypeConstraint::Class with itself or the class the TC represents as an argument incorrectly returned true. This behavior is correct for is_type_of, not is_subtype_of. (Guillermo Roditi) * Use File::Temp for temp files created during tests. Previously, files were written to the t/ dir, which could cause problems of the user running the tests did not have write access to that directory.. (Chris Weyl, Ævar Arnfjörð Bjarmason) * Pass role arguments along when applying roles to instances. (doy, lsm) 1.01 Fri, Mar 26, 2010 [NEW FEATURES] * The handles option now also accepts a role type constraint in addition to a plain role name. (Florian Ragwitz) [OTHER] * Record the Sartak/doy debt properly in Changes (perigrin) 1.00 Tue, Mar 25, 2010 [BUG FIXES] * Moose::Meta::Attribute::Native::Trait::Code no longer creates reader methods by default. (Florian Ragwitz) [DOCUMENTATION] * Improve various parts of the documentation and fix many typos. (Dave Rolsky, Mateu Hunter, Graham Knop, Robin V, Jay Hannah, Jesse Luehrs) [OTHER] * Paid the $10 debt to doy from 0.80 Sat, Jun 6, 2009 (Sartak) 0.99 Mon, Mar 8, 2010 [NEW FEATURES] * New method find_type_for in Moose::Meta::TypeConstraint::Union, for finding which member of the union a given value validates for. (Cory Watson) [BUG FIXES] * DEMOLISH methods in mutable subclasses of immutable classes are now called properly (Chia-liang Kao, Jesse Luehrs) [NEW DOCUMENTATION] * Added Moose::Manual::Support that defines the support, compatiblity, and release policies for Moose. (Chris Prather) 0.98 Wed, Feb 10, 2010 [BUG FIXES] * An internals change in 0.97 broke role application to an instance in some cases. The bug occurred when two different roles were applied to different instances of the same class. (Rafael Kitover) 0.97 Tue, Feb 9, 2010 [BUG FIXES] * Calling ->reinitialize on a cached anonymous class effectively uncached the metaclass object, causing the metaclass to go out of scope unexpectedly. This could easily happen at a distance by applying a metarole to an anonymous class. (Dave Rolsky). 0.96 Sat, Feb 6, 2010 [NEW FEATURES] * ScalarRef is now a parameterized type. You can now specify a type constraint for whatever the reference points to. (Closes RT#50857) (Michael G. Schwern, Florian Ragwitz) [BUG FIXES] * ScalarRef now accepts references to other references. (Closes RT#50934) (Michael G. Schwern) 0.95 Thu, Feb 4, 2010 [NEW FEATURES] * Moose::Meta::Attribute::Native::Trait::Code now provides execute_method as a delegation option. This allows the code reference to be called as a method on the object. (Florian Ragwitz) [ENHANCEMENTS] * Moose::Object::does no longer checks the entire inheritance tree, since Moose::Meta::Class::does_role already does this. (doy) * Moose::Util::add_method_modifier (and subsequently the sugar functions Moose::before, Moose::after, and Moose::around) can now accept arrayrefs, with the same behavior as lists. Types other than arrayref and regexp result in an error. (Dylan Hardison) 0.94 Mon, Jan 18, 2010 [API CHANGES] * Please see the changes listed for 0.93_01 and Moose::Manual::Delta. [ENHANCEMENTS] * Improved support for anonymous roles by changing various APIs to take Moose::Meta::Role objects as well as role names. This included - Moose::Meta::Class->does_role - Moose::Meta::Role->does_role - Moose::Util::does_role - Moose::Util::apply_all_roles - Moose::Util::ensure_all_roles - Moose::Util::search_class_by_role Requested by Shawn Moore. Addresses RT #51143 (and then some). (Dave Rolsky) [BUG FIXES] * Fix handling of non-alphanumeric attributes names like '@foo'. This should work as long as the accessor method names are explicitly set to valid Perl method names. Reported by Doug Treder. RT #53731. (Dave Rolsky) 0.93_03 Tue, Jan 5, 2010 [BUG FIXES] * Portability fixes to our XS code so we compile with 5.8.8 and Visual C++. Fixes RT #53391. Reported by Taro Nishino. (rafl) 0.93_02 Tue, Jan 5, 2010 [BUG FIXES] * Depend on Class::MOP 0.97_01 so we can get useful results from CPAN testers. (Dave Rolsky) 0.93_01 Mon, Jan 4, 2010 [API CHANGES] See Moose::Manual::Delta for more details on backwards compatiblity issues. * Role attributes are now objects of the Moose::Meta::Role::Attribute class. (Dave Rolsky). * There were major changes to how metaroles are applied. We now distinguish between metaroles for classes vs those for roles. See the Moose::Util::MetaRole docs for details. (Dave Rolsky) * The old MetaRole API has been deprecated, but will continue to work. However, if you are applying an attribute metaclass role, this may break because of the fact that roles now have an attribute metaclass too. (Dave Rolsky) * Moose::Util::MetaRole::apply_metaclass_roles is now called apply_metaroles. The old name is deprecated. (Dave Rolsky) * The unimport subs created by Moose::Exporter now clean up re-exported functions like blessed and confess, unless the caller imported them from somewhere else too. See Moose::Manua::Delta for backcompat details. (rafl) [ENHANCEMENTS AND BUG FIXES] * Changed the Str constraint to accept magic lvalue strings like one gets from substr et al, again. (sorear) * Sped up the type constraint parsing regex. (Sam Vilain) * The Moose::Cookbook::Extending::Recipe2 recipe was broken. Fix suggested by jrey. * Added Moose::Util::TypeConstraints exports when using oose.pm to allow easier testing of TypeConstraints from the command line. (perigrin) * Added a with_immutable test function to Test::Moose, to run a block of tests with and without certain classes being immutable. (doy) * We now use Module::Install extensions explicitly to avoid confusing errors if they're not installed. We use Module::Install::AuthorRequires to stop test extraction and general failures if you don't have the author side dependencies installed. * Fixed a grammar error in Moose::Cookbook::Basics::Recipe4. rt.cpan.org #51791. (Amir E. Aharoni) 0.93 Thu, Nov 19, 2009 * Moose::Object - Calling $object->new() is no longer deprecated, and no longer warns. (doy) * Moose::Meta::Role - The get_attribute_map method is now deprecated. (Dave Rolsky) * Moose::Meta::Method::Delegation - Preserve variable aliasing in @_ for delegated methods, so that altering @_ affects the passed value. (doy) * Moose::Util::TypeConstraints - Allow array refs for non-anonymous form of enum and duck_type, not just anonymous. The non-arrayref forms may be removed in the future. (doy) - Changed Str constraint to not accept globs (*STDIN or *FOO). (chansen) - Properly document Int being a subtype of Str. (doy) * Moose::Exporter - Moose::Exporter using modules can now export their functions to the main package. This applied to Moose and Moose::Role, among others. (nothingmuch) * Moose::Meta::Attribute - Don't remove attribute accessors we never installed, during remove_accessors. (doy) * Moose::Meta::Attribute::Native::Trait::Array - Don't bypass prototype checking when calling List::Util::first, to avoid a segfault when it is called with a non-code argument. (doy) * Moose::Meta::Attribute::Native::Trait::Code - Fix passing arguments to code execute helpers. (doy) 0.92 Tue, Sep 22, 2009 * Moose::Util::TypeConstraints - added the match_on_type operator (Stevan) - added tests and docs for this (Stevan) * Moose::Meta::Class - Metaclass compat fixing should already happen recursively, there's no need to explicitly walk up the inheritance tree. (doy) * Moose::Meta::Attribute - Add tests for set_raw_value and get_raw_value. (nothingmuch) 0.91 Thu, Sep 17, 2009 * Moose::Object - Don't import any functions, in order to avoid polluting our namespace with things that can look like methods (blessed, try, etc) (nothingmuch) * Moose::Meta::Method::Constructor - The generated code needs to called Scalar::Util::blessed by its fully-qualified name or else Perl can interpret the call to blessed as an indirect method call. This broke Search::GIN, which in turn broke KiokuDB. (nothingmuch) 0.90 Tue, Sep 15, 2009 * Moose::Meta::Attribute::Native::Trait::Counter * Moose::Meta::Attribute::Native::Trait::String - For these two traits, an attribute which did not explicitly provide methods to handles magically ended up delegating *all* the helper methods. This has been removed. You must be explicit in your handles declaration for all Native Traits. (Dave Rolsky) * Moose::Object - DEMOLISHALL behavior has changed. If any DEMOLISH method dies, we make sure to rethrow its error message. However, we also localize $@ before this so that if all the DEMOLISH methods success, the value of $@ will be preserved. (nothingmuch and Dave Rolsky) - We now also localize $? during object destruction. (nothingmuch and Dave Rolsky) - The handling of DEMOLISH methods was broken for immutablized classes, which were not receiving the value of Devel::GlobalDestruction::in_global_destruction. - These two fixes address some of RT #48271, reported by Zefram. - This is all now documented in Moose::Manual::Construction. - Calling $object->new() is now deprecated. A warning will be issued. (perigrin) * Moose::Meta::Role - Added more hooks to customize how roles are applied. The role summation class, used to create composite roles, can now be changed and/or have meta-roles applied to it. (rafl) - The get_method_list method no longer explicitly excludes the "meta" method. This was a hack that has been replaced by better hacks. (Dave Rolsky) * Moose::Meta::Method::Delegation - fixed delegated methods to make sure that any modifiers attached to the accessor being delegated on will be called (Stevan) - added tests for this (Stevan) * Moose::Meta::Class - Moose no longer warns when a class that is being made immutable has mutable ancestors. While in theory this is a good thing to warn about, we found so many exceptions to this that doing this properly became quite problematic. 0.89_02 Thu, Sep 10, 2009 * Moose::Meta::Attribute::Native - Fix Hash, which still had 'empty' instead of 'is_empty'. (hdp) * Moose::Meta::Attribute::Native::Trait::Array - Added a number of functions from List::Util and List::MoreUtils, including reduce, shuffle, uniq, and natatime. (doy) * Moose::Exporter - This module will now generate an init_meta method for your exporting class if you pass it options for Moose::Util::MetaRole::apply_metaclass_roles or apply_base_class_roles. This eliminates a lot of repetitive boilerplate for typical MooseX modules. (doy). - Documented the with_meta feature, which is a replacement for with_caller. This feature was added by josh a while ago. - The with_caller feature is now deprecated, but will not issue a warning yet. (Dave Rolsky) - If you try to wrap/export a subroutine which doesn't actually exist, Moose::Exporter will warn you about this. (doy) * Moose::Meta::Role::Application::ToRole - When a role aliased a method from another role, it was only getting the new (aliased) name, not the original name. This differed from what happens when a class aliases a role's methods. If you _only_ want the aliased name, make sure to also exclue the original name. (Dave Rolsky) 0.89_01 Wed Sep 2, 2009 * Moose::Meta::Attribute - Added the currying syntax for delegation from AttributeHelpers to the existing delegation API. (hdp) * Moose::Meta::Attribute::Native - We have merged the functionality of MooseX::AttributeHelpers into the Moose core with some API tweaks. You can continue to use MooseX::AttributeHelpers, but it will not be maintained except (perhaps) for critical bug fixes in the future. See Moose::Manual::Delta for details. (hdp, jhannah, rbuels, Sartak, perigrin, doy) * Moose::Error::Croak * Moose::Error::Confess - Clarify documentation on how to use different error-throwing modules. (Curtis Jewell) * Moose - Correct POD for builder to point to Recipe8, not 9. (gphat) * Moose::Exporter - When a nonexistent sub name is passed to as_is, with_caller, or with_meta, throw a warning and skip the exporting, rather than installing a broken sub. (doy) * Moose::Meta::Class - Moose now warns if you call C for a class with mutable ancestors. (doy) 0.89 Thu Aug 13, 2009 * Moose::Manual::Attributes - Clarify "is", include discussion of "bare". (Sartak) * Moose::Meta::Role::Method::Conflicting * Moose::Meta::Role::Application::ToClass - For the first set of roles involved in a conflict, report all unresolved method conflicts, not just the first method. Fixes #47210 reported by Ovid. (Sartak) * Moose::Meta::TypeConstraint - Add assert_valid method to use a TypeConstraint for assertion (rjbs) * Moose::Exporter - Make "use Moose -metaclass => 'Foo'" do alias resolution, like -traits does. (doy) - Allow specifying role options (alias, excludes, MXRP stuff) in the arrayref passed to "use Moose -traits" (doy) * Moose::Util - Add functions meta_class_alias and meta_attribute_alias for creating aliases for class and attribute metaclasses and metatraits. (doy) * Moose::Meta::Attribute * Moose::Meta::Method::Accessor - A trigger now receives the old value as a second argument, if the attribute had one. (Dave Rolsky) * Moose::Meta::Method::Constructor - Fix a bug with $obj->new when $obj has stringify overloading. Reported by Andrew Suffield [rt.cpan.org #47882] (Sartak) - However, we will probably deprecate $obj->new, so please don't start using it for new code! * Moose::Meta::Role::Application * Moose::Meta::Role::Application::RoleSummation - Rename alias and excludes to -alias and -excludes (but keep the old names for now, for backcompat) (doy) 0.88 Fri Jul 24, 2009 * Moose::Manual::Contributing - Re-write the Moose::Manual::Contributing document to reflect the new layout and methods of work for the Git repository. All work now should be done in topic branches and reviewed by a core committer before being applied to master. All releases are done by a cabal member and merged from master to stable. This plan was devised by Yuval, blame him. (perigrin) * Moose::Meta::Role - Create metaclass attributes for the different role application classes. (rafl) * Moose::Util::MetaRole - Allow applying roles to a meta role's role application classes. (rafl) * Moose::Meta::Attribute - Add weak_ref to allowed options for "has '+foo'" (mst) * Moose::Meta::Method::Accessor - No longer uses inline_slot_access in accessors, to support non-lvalue-based meta instances. (sorear) 0.87 Tue Jul 7, 2009 * Moose::Meta::Method::Delegation - Once again allow class names as well as objects for delegation. This was changed in 0.86. 0.86 Fri Jul 3, 2009 * Moose::Meta::Class::Immutable::Trait - Fixes to work with the latest Class::MOP. * Moose::Meta::Method::Delegation - Delegation now dies with a more useful error message if the attribute's accessor returns something defined but unblessed. (hdp) 0.85 Fri, Jun 26, 2009 * Moose::Meta::Attribute - The warning for 'no associated methods' is now split out into the _check_associated_methods method, so that extensions can safely call 'after install_accessors => ...'. This fixes a warning from MooseX::AttributeHelpers. (hdp) 0.84 Fri, Jun 26, 2009 * Moose::Role - has now sets definition_context for attributes defined in roles. (doy) * Moose::Meta::Attribute - When adding an attribute to a metaclass, if the attribute has no associated methods, it will give a deprecation warning. (hdp) - Methods generated by delegation were not being added to associated_methods. (hdp) - Attribute accessors (reader, writer, accessor, predicate, clearer) now warn if they overwrite an existing method. (doy) - Attribute constructors now warn very noisily about unknown (or misspelled) arguments * Moose::Util::TypeConstraints - Deprecated the totally useless Role type name, which just checked if $object->can('does'). Note that this is _not_ the same as a type created by calling role_type('RoleName'). * Moose::Util::TypeConstraints * Moose::Meta::TypeConstraint::DuckType - Reify duck type from a regular subtype into an actual class (Sartak) - Document this because Sartak did all my work for me (perigrin) * Moose::Meta::Attribute - Allow Moose::Meta::TypeConstraint::DuckType in handles, since it is just a list of methods (Sartak) * Moose::Meta::Role - The get_*_method_modifiers methods would die if the role had no modifiers of the given type (Robert Buels). 0.83 Tue, Jun 23, 2009 * Moose::Meta::Class - Fix _construct_instance not setting the special __MOP__ object key in instances of anon classes. (doy) 0.82 Sun, Jun 21, 2009 * Moose::Manual::Types - Mention MooseX::Types early to avoid users falling down the string parsing rathole (mst) * Moose::Manual::MooseX - Add warnings about class-level extensions and mention considering using plain objects instead 0.81 Sun, Jun 7, 2009 * Bumped our Class::MOP prereq to the latest version (0.85), since that's what we need. 0.80 Sat, Jun 6, 2009 * Moose::Manual::FAQ - Add FAQ about the coercion change from 0.76 because it came up three times today (perigrin) - Win doy $10 dollars because Sartak didn't think anybody would document this fast enough (perigrin) * Moose::Meta::Method::Destructor - Inline a DESTROY method even if there are no DEMOLISH methods to prevent unnecessary introspection in Moose::Object::DEMOLISHALL * Moose::* - A role's required methods are now represented by Moose::Meta::Role::Method::Required objects. Conflicts are now represented by Moose::Meta::Role::Method::Conflicting objects. The benefit for end-users in that unresolved conflicts generate different, more instructive, errors, resolving Ovid's #44895. (Sartak) * Moose::Role - Improve the error message of "extends" as suggested by Adam Kennedy and confound (Sartak) - Link to Moose::Manual::Roles from Moose::Role as we now have excellent documentation (Adam Kennedy) * Tests - Update test suite for subname change in Class::MOP (nothingmuch) - Add TODO test for infinite recursion in Moose::Meta::Class (groditi) 0.79 Wed, May 13, 2009 * Tests - More fixes for Win32 problems. Reported by Robert Krimen. * Moose::Object - The DEMOLISHALL method could still blow up in some cases during global destruction. This method has been made more resilient in the face of global destruction's random garbage collection order. * Moose::Exporter - If you "also" a module that isn't loaded, the error message now acknowledges that (Sartak) * Moose - When your ->meta method does not return a Moose::Meta::Class, the error message gave the wrong output (Sartak) 0.78 Tue, May 12, 2009 * Moose::Cookbook::FAQ and Moose::Cookbook::WTF - Merged these documents into what is now Moose::Manual::FAQ * Moose::Unsweetened - Moved to Moose::Manual::Unsweetened * Moose::Cookbook::Basics::Recipes 9-12 - Renamed to be 8-11, since recipe 8 did not exist * Moose::Exporter - Make Moose::Exporter import strict and warnings into packages that use it (doy) * Moose::Object - Fix DEMOLISHALL sometimes not being able to find DEMOLISH methods during global destruction (doy) * Moose::Meta::Class * Moose::Meta::Role::Application::ToClass - Track the Role::Application objects created during class-role consumption (Sartak) * Moose::Meta::Class - Fix metaclass incompatibility errors when extending a vanilla perl class which isa Moose class with a metaclass role applied (t0m) * Moose::Meta::Role - Add a role-combination hook, _role_for_combination, for the benefit of MooseX::Role::Parameterized (Sartak) * Tests - Some tests were failing on Win32 because they explicit checked warning output for newlines. Reported by Nickolay Platonov. 0.77 Sat, May 2, 2009 * Moose::Meta::Role - Add explicit use of Devel::GlobalDestruction and Sub::Name (perigrin) * Moose::Object - Pass a boolean to DEMOLISHALL and DEMOLISH indicating whether or not we are currently in global destruction (doy) - Add explicit use of Devel::GlobalDestruction and Sub::Name (perigrin) * Moose::Cookbook::FAQ - Reworked much of the existing content to be more useful to modern Moose hackers (Sartak) * Makefile.PL - Depend on Class::MOP 0.83 instead of 0.82_01. 0.76 Mon, April 27, 2009 * Moose::Meta::TypeConstraint - Do not run coercions in coerce() if the value already passes the type constraint (hdp) * Moose::Meta::TypeConstraint::Class - In validation error messages, specifically say that the value is not an instance of the class. This should alleviate some frustrating forgot-to-load-my-type bugs. rt.cpan.org #44639 (Sartak) * Moose::Meta::Role::Application::ToClass - Revert the class-overrides-role warning in favor of a solution outside of the Moose core (Sartak) * Tests - Make Test::Output optional again, since it's only used in a few files (Sartak) 0.75_01 Thu, April 23, 2009 * Moose::Meta::Role::Application::ToClass - Moose now warns about each class overriding methods from roles it consumes (Sartak) * Tests - Warnings tests have standardized on Test::Output which is now an unconditionally dependency (Sartak) * Moose::Meta::Class - Changes to immutabilization to work with Class::MOP 0.82_01+. 0.75 Mon, April 20, 2009 * Moose * Moose::Meta::Class - Move validation of not inheriting from roles from Moose::extends to Moose::Meta::Class::superclasses (doy) * Moose::Util - add ensure_all_roles() function to encapsulate the common "apply this role unless the object already does it" pattern (hdp) * Moose::Exporter - Users can now select a different metaclass with the "-metaclass" option to import, for classes and roles (Sartak) * Moose::Meta::Role - Make method_metaclass an attr so that it can accept a metarole application. (jdv) 0.74 Tue, April 7, 2009 * Moose::Meta::Role * Moose::Meta::Method::Destructor - Include stack traces in the deprecation warnings. (Florian Ragwitz) * Moose::Meta::Class - Removed the long-deprecated _apply_all_roles method. * Moose::Meta::TypeConstraint - Removed the long-deprecated union method. 0.73_02 Mon, April 6, 2009 * More deprecations and renamings - Moose::Meta::Method::Constructor - initialize_body => _initialize_body (this is always called when an object is constructed) * Moose::Object - The DEMOLISHALL method could throw an exception during global destruction, meaning that your class's DEMOLISH methods would not be properly called. Reported by t0m. * Moose::Meta::Method::Destructor - Destructor inlining was totally broken by the change to the is_needed method in 0.72_01. Now there is a test for this feature, and it works again. * Moose::Util - Bold the word 'not' in the POD for find_meta (t0m) 0.73_01 Sun, April 5, 2009 * Moose::* - Call user_class->meta in fewer places, with the eventual goal of allowing the user to rename or exclude ->meta altogether. Instead uses Class::MOP::class_of. (Sartak) * Moose::Meta::Method::Accessor - If an attribute had a lazy default, and that value did not pass the attribute's type constraint, it did not get the message from the type constraint, instead using a generic message. Test provided by perigrin. * Moose::Util::TypeConstraints - Add duck_type keyword. It's sugar over making sure an object can() a list of methods. This is easier than jrockway's suggestion to fork all of CPAN. (perigrin) - add tests and documentation (perigrin) * Moose - Document the fact that init_meta() returns the target class's metaclass object. (hdp) * Moose::Cookbook::Extending::Recipe1 * Moose::Cookbook::Extending::Recipe2 * Moose::Cookbook::Extending::Recipe3 * Moose::Cookbook::Extending::Recipe4 - Make init_meta() examples explicitly return the metaclass and point out this fact. (hdp) * Moose::Cookbook::Basics::Recipe12 - A new recipe, creating a custom meta-method class. * Moose::Cookbook::Meta::Recipe6 - A new recipe, creating a custom meta-method class. * Moose::Meta::Class * Moose::Meta::Method::Constructor - Attribute triggers no longer receive the meta-attribute object as an argument in any circumstance. Previously, triggers called during instance construction were passed the meta-attribute, but triggers called by normal accessors were not. Fixes RT#44429, reported by Mark Swayne. (hdp) * Moose::Manual::Attributes - Remove references to triggers receving the meta-attribute object as an argument. (hdp) * Moose::Cookbook::FAQ - Remove recommendation for deprecated Moose::Policy and Moose::Policy::FollowPBP; recommend MooseX::FollowPBP instead. (hdp) * Many methods have been renamed with a leading underscore, and a few have been deprecated entirely. The methods with a leading underscore are consider "internals only". People writing subclasses or extensions to Moose should feel free to override them, but they are not for "public" use. - Moose::Meta::Class - check_metaclass_compatibility => _check_metaclass_compatibility - Moose::Meta::Method::Accessor - initialize_body => _initialize_body (this is always called when an object is constructed) - /(generate_.*_method(?:_inline)?)/ => '_' . $1 - Moose::Meta::Method::Constructor - initialize_body => _initialize_body (this is always called when an object is constructed) - /(generate_constructor_method(?:_inline)?)/ => '_' . $1 - attributes => _attributes (now inherited from parent) - meta_instance => _meta_instance (now inherited from parent) - Moose::Meta::Role - alias_method is deprecated. Use add_method 0.73 Fri, March 29, 2009 * No changes from 0.72_01. 0.72_01 Thu, March 26, 2009 * Everything - Almost every module has complete API documentation. A few methods (and even whole classes) have been intentionally excluded pending some rethinking of their APIs. * Moose::Util::TypeConstraints - Calling subtype with a name as the only argument is now an exception. If you want an anonymous subtype do: my $subtype = subtype as 'Foo'; * Moose::Cookbook::Meta::Recipe7 - A new recipe, creating a custom meta-instance class. * Moose::Cookbook::Basics::Recipe5 - Fix various typos and mistakes. Includes a patch from Radu Greab. * Moose::Cookbook::Basics::Recipe9 - Link to this recipe from Moose.pm's builder blurb * Moose::Exporter - When wrapping a function with a prototype, Moose::Exporter now makes sure the wrapped function still has the same prototype. (Daisuke Maki) * Moose::Meta::Attribute - Allow a subclass to set lazy_build for an inherited attribute. (hdp) * Makefile.PL - Explicitly depend on Data::OptList. We already had this dependency via Sub::Exporter, but since we're using it directly we're better off with it listed. (Sartak) * Moose::Meta::Method::Constructor - Make it easier to subclass the inlining behaviour. (Ash Berlin) * Moose::Manual::Delta - Details significant changes in the history of Moose, along with recommended workarounds. * Moose::Manual::Contributing - Contributor's guide to Moose. * Moose::Meta::Method::Constructor - The long-deprecated intialize_body method has been removed (yes, spelled like that). * Moose::Meta::Method::Destructor - This is_needed method is now always a class method. * Moose::Meta::Class - Changes to the internals of how make_immutable works to match changes in latest Class::MOP. 0.72 Mon, February 23, 2009 * Moose::Object * Moose::Meta::Method::Constructor - A mutable class accepted Foo->new(undef) without complaint, while an immutable class would blow up with an unhelpful error. Now, in both cases we throw a helpful error instead. Reported by doy. 0.71_01 Sun, February 22, 2009 * Moose::Cookbook - Hopefully fixed some POD errors in a few recipes that caused them to display weird on search.cpan.org. * Moose::Util::TypeConstraints - Calling type or subtype without the sugar helpers (as, where, message) is now deprecated. - The subtype function tried hard to guess what you meant, but often got it wrong. For example: my $subtype = subtype as 'ArrayRef[Object]'; This caused an error in the past, but now works as you'd expect. * Everywhere - Make sure Moose.pm is loaded before calling Moose->throw_error. This wasn't normally an issue, but could bite you in weird cases. 0.71 Thu, February 19, 2009 * Moose::Cookbook::Basics::Recipe11 - A new recipe which demonstrates the use of BUILDARGS and BUILD. (Dave Rolsky) * Moose::Cookbook::Roles::Recipe3 - A new recipe, applying a role to an object instance. (Dave Rolsky) * Moose::Exporter - Allow overriding specific keywords from "also" packages. (doy) * Tests - Replace hardcoded cookbook tests with Test::Inline to ensure the tests match the actual code in the recipes. (Dave Rolsky) * Moose::Cookbook - Working on the above turned up a number of little bugs in the recipe code. (Dave Rolsky) * Moose::Util::TypeConstraints::Optimized - Just use Class::MOP for the optimized ClassName check. (Dave Rolsky) 0.70 Sat, February 14, 2009 * Moose::Util::TypeConstraints - Added the RoleName type (stevan) - added tests for this (stevan) * Moose::Cookbook::Basics::Recipe3 - Updated the before qw[left right] sub to be a little more defensive about what it accepts (stevan) - added more tests to t/000_recipies/basics/003_binary_tree.t (stevan) * Moose::Object - We now always call DEMOLISHALL, even if a class does not define DEMOLISH. This makes sure that method modifiers on DEMOLISHALL work as expected. (doy) - added tests for this (EvanCarroll) * Moose::Util::MetaRole - Accept roles for the wrapped_method_metaclass (rafl) - added tests for this (rafl) * Moose::Meta::Attribute - We no longer pass the meta-attribute object as a final argument to triggers. This actually changed for inlined code a while back, but the non-inlined version and the docs were still out of date. * Tests - Some tests tried to use Test::Warn 0.10, which had bugs. Now they require 0.11. (Dave Rolsky) * Documentation - Lots of small changes to the manual, cookbook, and elsewhere. These were based on feedback from various users, too many to list here. (Dave Rolsky) 0.69 Thu, February 12, 2009 * Moose - Make some keyword errors use throw_error instead of croak since Moose::Exporter wraps keywords now (Sartak) * Moose::Cookbook::* - Revised every recipe for style and clarity. Also moved some documentation out of cookbook recipes and into Moose::Manual pages. This work was funded as part of the Moose docs grant from TPF. (Dave Rolsky) * Moose::Meta::Method::Delegation - If the attribute doing the delegation was not populated, the error message did not specify the attribute name properly. (doy) 0.68 Wed, February 4, 2009 * POD - Many spelling, typo, and formatting fixes by daxim. * Moose::Manual::Attributes - The NAME section in the POD used "Attribute" so search.cpan didn't resolve links from other documents properly. * Moose::Meta::Method::Overriden - Now properly spelled as Overridden. Thanks to daxim for noticing this. 0.67 Tue, February 3, 2009 * Moose::Manual::* - Lots of little typo fixes and a few clarifications. Several pages didn't have proper titles, and so weren't actually visible on search.cpan.org. Thanks to hanekomu for a variety of fixes and formatting improvements. 0.66 Tue, February 3, 2009 * Moose::Manual - This is a brand new, extensive manual for Moose. This aims to provide a complete introduction to all of Moose's features. This work was funded as part of the Moose docs grant from TPF. (Dave Rolsky) * Moose::Meta::Attribute - Added a delegation_metaclass method to replace a hard-coded use of Moose::Meta::Method::Delegation. (Dave Rolsky) * Moose::Util::TypeConstraints - If you created a subtype and passed a parent that Moose didn't know about, it simply ignored the parent. Now it automatically creates the parent as a class type. This may not be what you want, but is less broken than before. (Dave Rolsky) * Moose::Util::TypeConstraints - This module tried throw errors by calling Moose->throw_error, but it did not ensure that Moose was loaded first. This could cause very unhelpful errors when it tried to throw an error before Moose was loaded. (Dave Rolsky) * Moose::Util::TypeConstraints - You could declare a name with subtype such as "Foo!Bar" that would be allowed, but if you used it in a parameterized type such as "ArrayRef[Foo!Bar]" it wouldn't work. We now do some vetting on names created via the sugar functions, so that they can only contain alphanumerics, ":", and ".". (Dave Rolsky) 0.65 Thu, January 22, 2009 * Moose and Moose::Meta::Method::Overridden - If an overridden method called super(), and then the superclass's method (not overridden) _also_ called super(), Moose went into an endless recursion loop. Test provided by Chris Prather. (Dave Rolsky) * Moose::Meta::TypeConstraint - All methods are now documented. (gphat) * t/100_bugs/011_DEMOLISH_eats_exceptions.t - Fixed some bogus failures that occurred because we tried to validate filesystem paths in a very ad-hoc and not-quite-correct way. (Dave Rolsky) * Moose::Util::TypeConstraints - Added maybe_type to exports. See docs for details. (rjbs) * Moose - Added Moose::Util::TypeConstraints to the SEE ALSO section. (pjf) * Moose::Role - Methods created via an attribute can now fulfill a "requires" declaration for a role. (nothingmuch) * Moose::Meta::Method::* - Stack traces from inlined code will now report its line and file as being in your class, as opposed to in Moose guts. (nothingmuch). 0.64 Wed, December 31, 2008 * Moose::Meta::Method::Accessor - Always inline predicate and clearer methods (Sartak) * Moose::Meta::Attribute - Support for parameterized traits (Sartak) - verify_against_type_constraint method to avoid duplication and enhance extensibility (Sartak) * Moose::Meta::Class - Tests (but no support yet) for parameterized traits (Sartak) * Moose - Require Class::MOP 0.75+, which has the side effect of making sure we work on Win32. (Dave Rolsky) 0.63 Mon, December 8, 2008 * Moose::Unsweetened - Some small grammar tweaks and bug fixes in non-Moose example code. (Dave Rolsky) 0.62_02 Fri, December 5, 2008 * Moose::Meta::Role::Application::ToClass - When a class does not provide all of a role's required methods, the error thrown now mentions all of the missing methods, as opposed to just the first one found. Requested by Curtis Poe (RT #41119). (Dave Rolsky) * Moose::Meta::Method::Constructor - Moose will no longer inline a constructor for your class unless it inherits its constructor from Moose::Object, and will warn when it doesn't inline. If you want to force inlining anyway, pass "replace_constructor => 1" to make_immutable. Addresses RT #40968, reported by Jon Swartz. (Dave Rolsky) - The quoting of default values could be broken if the default contained a single quote ('). Now we use quotemeta to escape anything potentially dangerous in the defaults. (Dave Rolsky) 0.62_01 Wed, December 3, 2008 * Moose::Object - use the method->execute API for BUILDALL and DEMOLISHALL (Sartak) * Moose::Util::TypeConstraints - We now make all the type constraint meta classes immutable before creating the default types provided by Moose. This should make loading Moose a little faster. (Dave Rolsky) 0.62 Wed November 26, 2008 * Moose::Meta::Role::Application::ToClass Moose::Meta::Role::Application::ToRole - fixed issues where excluding and aliasing the same methods for a single role did not work right (worked just fine with multiple roles) (stevan) - added test for this (stevan) * Moose::Meta::Role::Application::RoleSummation - fixed the error message when trying to compose a role with a role it excludes (Sartak) * Moose::Exporter - Catch another case where recursion caused the value of $CALLER to be stamped on (t0m) - added test for this (t0m) * Moose - Remove the make_immutable keyword, which has been deprecated since April. It breaks metaclasses that use Moose without no Moose (Sartak) * Moose::Meta::Attribute - Removing an attribute from a class now also removes delegation (handles) methods installed for that attribute (t0m) - added test for this (t0m) * Moose::Meta::Method::Constructor - An attribute with a default that looked like a number (but was really a string) would accidentally be treated as a number when the constructor was made immutable (perigrin) - added test for this (perigrin) * Moose::Meta::Role - create method for constructing a role dynamically (Sartak) - added test for this (Sartak) - anonymous roles! (Sartak) - added test for this (Sartak) * Moose::Role - more consistent error messages (Sartak) * Moose::Cookbook::Roles::Recipe1 - attempt to explain why a role that just requires methods is useful (Sartak) 0.61 Fri November 7, 2008 * Moose::Meta::Attribute - When passing a role to handles, it will be loaded if necessary (perigrin) * Moose::Meta::Class - Method objects returned by get_method (and other methods) Could end up being returned without an associated_metaclass attribute. Removing get_method_map, which is provided by Class::MOP::Class, fixed this. The Moose version did nothing different from its parent except introduce a bug. (Dave Rolsky) - added tests for this (jdv79) * Various - Added a $VERSION to all .pm files which didn't have one. Fixes RT #40049, reported by Adam Kennedy. (Dave Rolsky) * Moose::Cookbook::Basics::Recipe4 * Moose::Cookbook::Basics::Recipe6 - These files had spaces on the first line of the SYNOPSIS, as opposed to a totally empty line. According to RT #40432, this confuses POD parsers. (Dave Rolsky) 0.60 Fri October 24, 2008 * Moose::Exporter - Passing "-traits" when loading Moose caused the Moose.pm exports to be broken. Reported by t0m. (Dave Rolsky) - Tests for this bug. (t0m) * Moose::Util - Change resolve_metaclass alias to use the new load_first_existing_class function. This makes it a lot simpler, and also around 5 times faster. (t0m) - Add caching to resolve_metaclass_alias, which gives an order of magnitude speedup to things which repeatedly call the Moose::Meta::Attribute->does method, notably MooseX::Storage (t0m) * Moose::Util::TypeConstraint - Put back the changes for parameterized constraints that shouldn't have been removed in 0.59. We still cannot parse them, but MooseX modules can create them in some other way. See the 0.58 changes for more details. (jnapiorkowski) - Changed the way subtypes are created so that the job is delegated to a type constraint parent. This clears up some hardcoded checking and should allow correct subtypes of Moose::Meta::Type::Constraint. Don't rely on this new API too much (create_child_type) because it may go away in the future. (jnapiorkowski) * Moose::Meta::TypeConstraint::Union - Type constraint names are sorted as strings, not numbers. (jnapiorkowski) * Moose::Meta::TypeConstraint::Parameterizable - New parameterize method. This can be used as a factory method to make a new type constraint with a given parameterized type. (jnapiorkowski) - added tests (jnapiorkowski) 0.59 Tue October 14, 2008 * Moose - Add abridged documentation for builder/default/initializer/ predicate, and link to more details sections in Class::MOP::Attribute. (t0m) * Moose::Util::TypeConstraints - removed prototypes from all but the &-based stuff (mst) * Moose::Util::TypeConstraints - Creating a anonymous subtype with both a constraint and a message failed with a very unhelpful error, but should just work. Reported by t0m. (Dave Rolsky) * Tests - Some tests that used Test::Warn if it was available failed with older versions of Test::Warn. Reported by Fayland. (Dave Rolsky) - Test firing behavior of triggers in relation to builder/default/ lazy_build. (t0m) - Test behavior of equals/is_a_type_of/is_a_subtype_of for all kinds of supported type. (t0m) * Moose::Meta::Class - In create(), do not pass "roles" option to the superclass - added related test that creates an anon metaclass with a required attribute * Moose::Meta::TypeConstraint::Class * Moose::Meta::TypeConstraint::Role - Unify behavior of equals/is_a_type_of/is_a_subtype_of with other types (as per change in 0.55_02). (t0m) * Moose::Meta::TypeConstraint::Registry - Fix warning when dealing with unknown type names (t0m) * Moose::Util::TypeConstraints - Reverted changes from 0.58 related to handle parameterized types. This caused random failures on BSD and Win32 systems, apparently related to the regex engine. This means that Moose can no longer parse structured type constraints like ArrayRef[Int,Int] or HashRef[name=>Str]. This will be supported in a slightly different way via MooseX::Types some time in the future. (Dave Rolsky) 0.58 Sat September 20, 2008 !! This release has an incompatible change regarding !! !! how roles add methods to a class !! * Roles and role application ! Roles now add methods by calling add_method, not alias_method. They make sure to always provide a method object, which will be cloned internally. This means that it is now possible to track the source of a method provided by a role, and even follow its history through intermediate roles. This means that methods added by a role now show up when looking at a class's method list/map. (Dave Rolsky) * Makefile.PL - From this release on, we'll try to maintain a list of conflicting modules, and warn you if you have one installed. For example, this release conflicts with ... - MooseX::Singleton <= 0.11 - MooseX::Params::Validate <= 0.05 - Fey::ORM <= 0.10 In general, we try to not break backwards compatibility for most Moose users, but MooseX modules and other code which extends Moose's metaclasses is often affected by very small changes in the Moose internals. * Moose::Meta::Method::Delegation * Moose::Meta::Attribute - Delegation methods now have their own method class. (Dave Rolsky) * Moose::Meta::TypeConstraint::Parameterizable - Added a new method 'parameterize' which is basically a factory for the containing constraint. This makes it easier to create new types of parameterized constraints. (jnapiorkowski) * Moose::Meta::TypeConstraint::Union - Changed the way Union types canonicalize their names to follow the normalized TC naming rules, which means we strip all whitespace. (jnapiorkowski) * Moose::Util::TypeConstraints - Parameter and Union args are now sorted, this makes Int|Str the same constraint as Str|Int. (jnapiorkowski) - Changes to the way Union types are parsed to more correctly stringify their names. (jnapiorkowski) - When creating a parameterized type, we now use the new parameterize method. (jnapiorkowski) - Incoming type constraint strings are now normalized to remove all whitespace differences. (jnapiorkowski) - Changed the way we parse type constraint strings so that we now match TC[Int,Int,...] and TC[name=>Str] as parameterized type constraints. This lays the foundation for more flexible type constraint implementations. * Tests and docs for all the above. (jnapiorkowski) * Moose::Exporter * Moose - Moose::Exporter will no longer remove a subroutine that the exporting package re-exports. Moose re-exports the Carp::confess function, among others. The reasoning is that we cannot know whether you have also explicitly imported those functions for your own use, so we err on the safe side and always keep them. (Dave Rolsky) - added tests for this (rafl) * Moose::Meta::Class - Changes to how we fix metaclass compatibility that are much too complicated to go into. The summary is that Moose is much less likely to complain about metaclass incompatibility now. In particular, if two metaclasses differ because Moose::Util::MetaRole was used on the two corresponding classes, then the difference in roles is reconciled for the subclass's metaclass. (Dave Rolsky) - Squashed an warning in _process_attribute (thepler) * Moose::Meta::Role - throw exceptions (sooner) for invalid attribute names (thepler) - added tests for this (thepler) * Moose::Util::MetaRole - If you explicitly set a constructor or destructor class for a metaclass object, and then applied roles to the metaclass, that explicitly set class would be lost and replaced with the default. * Moose::Meta::Class * Moose::Meta::Attribute * Moose::Meta::Method * Moose * Moose::Object * Moose::Error::Default * Moose::Error::Croak * Moose::Error::Confess - All instances of confess() changed to use overridable C method. This method ultimately calls a class constructor, and you can change the class being called. In addition, errors now pass more information than just a string. The default C behaves like C, so the behavior is not visibly different for end users. 0.57 Wed September 3, 2008 * Moose::Intro - A new bit of doc intended to introduce folks familiar with "standard" Perl 5 OO to Moose concepts. (Dave Rolsky) * Moose::Unsweetened - Shows examples of two classes, each done first with and then without Moose. This makes a nice parallel to Moose::Intro. (Dave Rolsky) * Moose::Util::TypeConstraints - Fixed a bug in find_or_parse_type_constraint so that it accepts a Moose::Meta::TypeConstraint object as the parent type, not just a name (jnapiorkowski) - added tests (jnapiorkowski) * Moose::Exporter - If Sub::Name was not present, unimporting failed to actually remove some sugar subs, causing test failures (Dave Rolsky) 0.56 Mon September 1, 2008 For those not following the series of dev releases, there are several major changes in this release of Moose. ! Moose::init_meta should now be called as a method. See the docs for details. - Major performance improvements by nothingmuch. - New modules for extension writers, Moose::Exporter and Moose::Util::MetaRole by Dave Rolsky. - Lots of doc improvements and additions, especially in the cookbook sections. - Various bug fixes. * Removed all references to the experimental-but-no-longer-needed Moose::Meta::Role::Application::ToMetaclassInstance. * Require Class::MOP 0.65. 0.55_04 Sat August 30, 2008 * Moose::Util::MetaRole * Moose::Cookbook::Extending::Recipe2 - This simplifies the application of roles to any meta class, as well as the base object class. Reimplemented metaclass traits using this module. (Dave Rolsky) * Moose::Cookbook::Extending::Recipe1 - This a new recipe, an overview of various ways to write Moose extensions (Dave Rolsky) * Moose::Cookbook::Extending::Recipe3 * Moose::Cookbook::Extending::Recipe4 - These used to be Extending::Recipe1 and Extending::Recipe2, respectively. 0.55_03 Fri August 29, 2008 * No changes from 0.55_02 except increasing the Class::MOP dependency to 0.64_07. 0.55_02 Fri August 29, 2008 * Makefile.PL and Moose.pm - explicitly require Perl 5.8.0+ (Dave Rolsky) * Moose::Util::TypeConstraints - Fix warnings from find_type_constraint if the type is not found (t0m). * Moose::Meta::TypeConstraint - Predicate methods (equals/is_a_type_of/is_subtype_of) now return false if the type you specify cannot be found in the type registry, rather than throwing an unhelpful and coincidental exception. (t0m). - added docs & test for this (t0m) * Moose::Meta::TypeConstraint::Registry - add_type_constraint now throws an exception if a parameter is not supplied (t0m). - added docs & test for this (t0m) * Moose::Cookbook::FAQ - Added a faq entry on the difference between "role" and "trait" (t0m) * Moose::Meta::Role - Fixed a bug that caused role composition to not see a required method when that method was provided by another role being composed at the same time. (Dave Rolsky) - test and bug finding (tokuhirom) 0.55_01 Wed August 20, 2008 !! Calling Moose::init_meta as a function is now !! !! deprecated. Please see the Moose.pm docs for details. !! * Moose::Meta::Method::Constructor - Fix inlined constructor so that values produced by default or builder methods are coerced as required. (t0m) - added test for this (t0m) * Moose::Meta::Attribute - A lazy attribute with a default or builder did not attempt to coerce the default value. The immutable code _did_ coerce. (t0m) - added test for this (t0m) * Moose::Exporter - This is a new helper module for writing "Moose-alike" modules. This should make the lives of MooseX module authors much easier. (Dave Rolsky) * Moose * Moose::Cookbook::Meta::Recipe5 - Implemented metaclass traits (and wrote a recipe for it): use Moose -traits => 'Foo' This should make writing small Moose extensions a little easier (Dave Rolsky) * Moose::Cookbook::Basics::Recipe1 - Removed any examples of direct hashref access, and applied an editorial axe to reduce verbosity. (Dave Rolsky) * Moose::Cookbook::Basics::Recipe1 - Also applied an editorial axe here. (Dave Rolsky) * Moose * Moose::Cookbook::Extending::Recipe1 * Moose::Cookbook::Extending::Recipe2 - Rewrote extending and embedding moose documentation and recipes to use Moose::Exporter (Dave Rolsky) * Moose * Moose::Role - These two modules now warn when you load them from the main package "main" package, because we will not export sugar to main. Previously it just did nothing. (Dave Rolsky) * Moose::Role - Now provide an init_meta method just like Moose.pm, and you can call this to provide an alternate role metaclass. (Dave Rolsky and nothingmuch) - get_method_map now respects the package cache flag (nothingmuch) * Moose::Meta::Role - Two new methods - add_method and wrap_method_body (nothingmuch) * many modules - Optimizations including allowing constructors to accept hash refs, making many more classes immutable, and making constructors immutable. (nothingmuch) 0.55 Sun August 3, 2008 * Moose::Meta::Attribute - breaking down the way 'handles' methods are created so that the process can be more easily overridden by subclasses (stevan) * Moose::Meta::TypeConstraint - fixing what is passed into a ->message with the type constraints (RT #37569) - added tests for this (Charles Alderman) * Moose::Util::TypeConstraints - fix coerce to accept anon types like subtype can (mst) * Moose::Cookbook - reorganized the recipes into sections - Basics, Roles, Meta, Extending - and wrote abstracts for each section (Dave Rolsky) * Moose::Cookbook::Basics::Recipe10 - A new recipe that demonstrates operator overloading in combination with Moose. (bluefeet) * Moose::Cookbook::Meta::Recipe1 - an introduction to what meta is and why you'd want to make your own metaclass extensions (Dave Rolsky) * Moose::Cookbook::Meta::Recipe4 - a very simple metaclass example (Dave Rolsky) * Moose::Cookbook::Extending::Recipe1 - how to write a Moose-alike module to use your own object base class (Dave Rolsky) * Moose::Cookbook::Extending::Recipe2 - how to write modules with an API just like C (Dave Rolsky) * all documentation - Tons of fixes, both syntactical and grammatical (Dave Rolsky, Paul Fenwick) 0.54 Thurs. July 3, 2008 ... this is not my day today ... * Moose::Meta::Attribute - fixed legal_options_for_inheritance such that clone_and_inherit options still works for Class::MOP::Attribute objects and therefore does not break MooseX::AttributeHelpers (stevan) 0.53 Thurs. July 3, 2008 * Whoops, I guess I should run 'make manifest' before actually releasing the module. No actual changes in this release, except the fact that it includes the changes that I didn't include in the last release. (stevan--) 0.52 Thurs. July 3, 2008 * Moose - added "FEATURE REQUESTS" section to the Moose docs to properly direct people (stevan) (RT #34333) - making 'extends' croak if it is passed a Role since this is not ever something you want to do (fixed by stevan, found by obra) - added tests for this (stevan) * Moose::Object - adding support for DOES (as in UNIVERSAL::DOES) (nothingmuch) - added test for this * Moose::Meta::Attribute - added legal_options_for_inheritance (wreis) - added tests for this (wreis) * Moose::Cookbook::Snacks::* - removed some of the unfinished snacks that should not have been released yet. Added some more examples to the 'Keywords' snack. (stevan) * Moose::Cookbook::Style - added general Moose "style guide" of sorts to the cookbook (nothingmuch) (RT #34335) * t/ - added more BUILDARGS tests (stevan) 0.51 Thurs. Jun 26, 2008 * Moose::Role - add unimport so "no Moose::Role" actually does something (sartak) * Moose::Meta::Role::Application::ToRole - when RoleA did RoleB, and RoleA aliased a method from RoleB in order to provide its own implementation, that method still got added to the list of required methods for consumers of RoleB. Now an aliased method is only added to the list of required methods if the role doing the aliasing does not provide its own implementation. See Recipe 11 for an example of all this. (Dave Rolsky) - added tests for this * Moose::Meta::Method::Constructor - when a single argument that wasn't a hashref was provided to an immutabilized constructor, the error message was very unhelpful, as opposed to the non-immutable error. Reported by dew. (Dave Rolsky) - added test for this (Dave Rolsky) * Moose::Meta::Attribute - added support for meta_attr->does("ShortAlias") (sartak) - added tests for this (sartak) - moved the bulk of the `handles` handling to the new install_delegation method (Stevan) * Moose::Object - Added BUILDARGS, a new step in new() * Moose::Meta::Role::Application::RoleSummation - fix typos no one ever sees (sartak) * Moose::Util::TypeConstraints * Moose::Meta::TypeConstraint * Moose::Meta::TypeCoercion - Attempt to work around the ??{ } vs. threads issue (not yet fixed) - Some null_constraint optimizations 0.50 Thurs. Jun 11, 2008 - Fixed a version number issue by bumping all modules to 0.50. 0.49 Thurs. Jun 11, 2008 !! This version now approx. 20-25% !! !! faster with new Class::MOP 0.59 !! * Moose::Meta::Attribute - fixed how the is => (ro|rw) works with custom defined reader, writer and accessor options. - added docs for this (TODO). - added tests for this (Thanks to Penfold) - added the custom attribute alias for regular Moose attributes which is "Moose" - fix builder and default both being used (groditi) * Moose Moose::Meta::Class Moose::Meta::Attribute Moose::Meta::Role Moose::Meta::Role::Composite Moose::Util::TypeConstraints - switched usage of reftype to ref because it is much faster * Moose::Meta::Role - changing add_package_symbol to use the new HASH ref form * Moose::Object - fixed how DEMOLISHALL is called so that it can be overrided in subclasses (thanks to Sartak) - added test for this (thanks to Sartak) * Moose::Util::TypeConstraints - move the ClassName type check code to Class::MOP::is_class_loaded (thanks to Sartak) * Moose::Cookbook::Recipe11 - add tests for this (thanks to tokuhirom) 0.48 Thurs. May 29, 2008 (early morning release engineering)-- - fixing the version in Moose::Meta::Method::Destructor which was causing the indexer to choke 0.47 Thurs. May 29, 2008 (late night release engineering)-- - fixing the version is META.yml, no functional changes in this release 0.46 Wed. May 28, 2008 !! This version now approx. 20-25% !! !! faster with new Class::MOP 0.57 !! * Moose::Meta::Class - some optimizations of the &initialize method since it is called so often by &meta * Moose::Meta::Class Moose::Meta::Role - now use the get_all_package_symbols from the updated Class::MOP, test suite is now 10 seconds faster * Moose::Meta::Method::Destructor - is_needed can now also be called as a class method for immutablization to check if the destructor object even needs to be created at all * Moose::Meta::Method::Destructor Moose::Meta::Method::Constructor - added more descriptive error message to help keep people from wasting time tracking an error that is easily fixed by upgrading. 0.45 Saturday, May 24, 2008 * Moose - Because of work in Class::MOP 0.57, all XS based functionality is now optional and a Pure Perl version is supplied - the CLASS_MOP_NO_XS environment variable can now be used to force non-XS versions to always be used - several of the packages have been tweaked to take care of this, mostly we added support for the package_name and name variables in all the Method metaclasses - before/around/after method modifiers now support regexp matching of names (thanks to Takatoshi Kitano) - tests added for this - NOTE: this only works for classes, it is currently not supported in roles, but, ... patches welcome - All usage of Carp::confess have been replaced by Carp::croak in the "keyword" functions since the stack trace is usually not helpful * Moose::Role - All usage of Carp::confess have been replaced by Carp::croak in the "keyword" functions since the stack trace is usually not helpful - The 'has' keyword for roles now accepts the same array ref form that Moose.pm does (has [qw/foo bar/] => (is => 'rw', ...)) - added test for this * Moose::Meta::Attribute - trigger on a ro-attribute is no longer an error, as it's useful to trigger off of the constructor * Moose::Meta::Class - added same 'add_package_symbol' fix as in Class::MOP 0.57 * Moose::Util - does_role now handles non-Moose classes more gracefully - added tests for this - added the 'add_method_modifier' function (thanks to Takatoshi Kitano) * Moose::Util::TypeConstraints - subtypes of parameterizable types now are themselves parameterizable types * Moose::Meta::Method::Constructor - fixed bug where trigger was not being called by the inlined immutable constructors - added test for this (thanks to Caelum) * Moose::Meta::Role::Application::ToInstance - now uses the metaclass of the instance (if possible) to create the anon-class (thanks Jonathan Rockway) * Moose::Cookbook::Recipe22 - added the meta-attribute trait recipe (thanks to Sartak) * t/ - fixed hash-ordering test bug that was causing occasional cpantester failures - renamed the t/000_recipe/*.t tests to be more descriptive (thanks to Sartak) 0.44 Sat. May 10, 2008 * Moose - made make_immutable warning cluck to show where the error is (thanks mst) * Moose::Object - BUILDALL and DEMOLISHALL now call ->body when looping through the methods, to avoid the overloaded method call. - fixed issue where DEMOLISHALL was eating the $@ values, and so not working correctly, it still kind of eats them, but so does vanilla perl - added tests for this * Moose::Cookbook::Recipe7 - added new recipe for immutable functionality (thanks Dave Rolsky) * Moose::Cookbook::Recipe9 - added new recipe for builder and lazy_build (thanks Dave Rolsky) * Moose::Cookbook::Recipe11 - added new recipe for method aliasing and exclusion with Roles (thanks Dave Rolsky) * t/ - fixed Win32 test failure (thanks spicyjack) ~ removed Build.PL and Module::Build compat since Module::Install has done that. 0.43 Wed. April, 30, 2008 * NOTE TO SELF: drink more coffee before doing release engineering - whoops, forgot to do the smolder tests, and we broke some of the custom meta-attr modules. This fixes that. 0.42 Mon. April 28, 2008 - some bad tests slipped by, nothing else changed in this release (cpantesters++) - upped the Class::MOP dependency to 0.55 since we have tests which need the C3 support 0.41 Mon. April 28, 2008 ~~ numerous documentation updates ~~ - Changed all usage of die to Carp::croak for better error reporting (initial patch by Tod Hagan) ** IMPORTANT NOTE ** - the make_immutable keyword is now deprecated, don't use it in any new code and please fix your old code as well. There will be 2 releases, and then it will be removed. * Moose Moose::Role Moose::Meta::Class - refactored the way inner and super work to avoid any method/@ISA cache penalty (nothingmuch) * Moose::Meta::Class - fixing &new_object to make sure trigger gets the coerced value (spotted by Charles Alderman on the mailing list) - added test for this * Moose::Meta::Method::Constructor - immutable classes which had non-lazy attributes were calling the default generating sub twice in the constructor. (bug found by Jesse Luehrs, fixed by Dave Rolsky) - added tests for this (Dave Rolsky) - fix typo in initialize_body method (nothingmuch) * Moose::Meta::Method::Destructor - fix typo in initialize_body method (nothingmuch) * Moose::Meta::Method::Overriden Moose::Meta::Method::Augmented - moved the logic for these into their own classes (nothingmuch) * Moose::Meta::Attribute - inherited attributes may now be extended without restriction on the type ('isa', 'does') (Sartak) - added tests for this (Sartak) - when an attribute property is malformed (such as lazy without a default), give the name of the attribute in the error message (Sartak) - added the &applied_traits and &has_applied_traits methods to allow introspection of traits - added tests for this - moved 'trait' and 'metaclass' argument handling to here from Moose::Meta::Class - clone_and_inherit_options now handles 'trait' and 'metaclass' (has '+foo' syntax) (nothingmuch) - added tests for this (t0m) * Moose::Object - localize $@ inside DEMOLISHALL to avoid it eating $@ (found by Ernesto) - added test for this (thanks to Ernesto) * Moose::Util::TypeConstraints - &find_type_constraint now DWIMs when given an type constraint object or name (nothingmuch) - &find_or_create_type_constraint superseded with a number of more specific functions: - find_or_create_{isa,does}_type_constraint - find_or_parse_type_constraint * Moose::Meta::TypeConstraint Moose::Meta::TypeConstraint::Class Moose::Meta::TypeConstraint::Role Moose::Meta::TypeConstraint::Enum Moose::Meta::TypeConstraint::Union Moose::Meta::TypeConstraint::Parameterized - added the &equals method for comparing two type constraints (nothingmuch) - added tests for this (nothingmuch) * Moose::Meta::TypeConstraint - add the &parents method, which is just an alias to &parent. Useful for polymorphism with TC::{Class,Role,Union} (nothingmuch) * Moose::Meta::TypeConstraint::Class - added the class attribute for introspection purposes (nothingmuch) - added tests for this * Moose::Meta::TypeConstraint::Enum Moose::Meta::TypeConstraint::Role - broke these out into their own classes (nothingmuch) * Moose::Cookbook::Recipe* - fixed references to test file locations in the POD and updated up some text for new Moose features (Sartak) * Moose::Util - Added &resolve_metaclass_alias, a helper function for finding an actual class for a short name (e.g. in the traits list) 0.40 Fri. March 14, 2008 - I hate Pod::Coverage 0.39 Fri. March 14, 2008 * Moose - documenting the use of '+name' with attributes that come from recently composed roles. It makes sense, people are using it, and so why not just officially support it. - fixing the 'extends' keyword so that it will not trigger Ovid's bug (http://use.perl.org/~Ovid/journal/35763) * oose - added the perl -Moose=+Class::Name feature to allow monkeypatching of classes in one liners * Moose::Util - fixing the 'apply_all_roles' keyword so that it will not trigger Ovid's bug (http://use.perl.org/~Ovid/journal/35763) * Moose::Meta::Class - added ->create method which now supports roles (thanks to jrockway) - added tests for this - added ->create_anon_class which now supports roles and caching of the results (thanks to jrockway) - added tests for this - made ->does_role a little more forgiving when it is checking a Class::MOP era metaclasses. * Moose::Meta::Role::Application::ToInstance - it is now possible to pass extra params to be used when a role is applied to an the instance (rebless_params) - added tests for this * Moose::Util::TypeConstraints - class_type now accepts an optional second argument for a custom message. POD anotated accordingly (groditi) - added tests for this - it is now possible to make anon-enums by passing 'enum' an ARRAY ref instead of the $name => @values. Everything else works as before. - added tests for this * t/ - making test for using '+name' on attributes consumed from a role, it works and makes sense too. * Moose::Meta::Attribute - fix handles so that it doesn't return nothing when the method cannot be found, not sure why it ever did this originally, this means we now have slightly better support for AUTOLOADed objects - added more delegation tests - adding ->does method to this so as to better support traits and their introspection. - added tests for this * Moose::Object - localizing the Data::Dumper configurations so that it does not pollute others (RT #33509) - made ->does a little more forgiving when it is passed Class::MOP era metaclasses. 0.38 Fri. Feb. 15, 2008 * Moose::Meta::Attribute - fixed initializer to correctly do type checking and coercion in the callback - added tests for this * t/ - fixed some finicky tests (thanks to konobi) 0.37 Thurs. Feb. 14, 2008 * Moose - fixed some details in Moose::init_meta and its superclass handling (thanks thepler) - added tests for this (thanks thepler) - 'has' now dies if you don't pass in name value pairs - added the 'make_immutable' keyword as a shortcut to make_immutable * Moose::Meta::Class Moose::Meta::Method::Constructor Moose::Meta::Attribute - making (init_arg => undef) work here too (thanks to nothingmuch) * Moose::Meta::Attribute Moose::Meta::Method::Constructor Moose::Meta::Method::Accessor - make lazy attributes respect attr initializers (rjbs) - added tests for this * Moose::Util::TypeConstraints Moose::Util::TypeConstraints::OptimizedConstraints Moose::Meta::TypeConstraints Moose::Meta::Attribute Moose::Meta::Method::Constructor Moose::Meta::Method::Accessor - making type errors use the assigned message (thanks to Sartak) - added tests for this * Moose::Meta::Method::Destructor - making sure DESTROY gets inlined properly with successive DEMOLISH calls (thanks to manito) * Moose::Meta::Attribute Moose::Meta::Method::Accessor - fixed handling of undef with type constraints (thanks to Ernesto) - added tests for this * Moose::Util - added &get_all_init_args and &get_all_attribute_values (thanks to Sartak and nothingmuch) 0.36 Sat. Jan. 26, 2008 * Moose::Role Moose::Meta::Attribute - role type tests now support when roles are applied to non-Moose classes (found by ash) - added tests for this (thanks to ash) - couple extra tests to boost code coverage * Moose::Meta::Method::Constructor - improved fix for handling Class::MOP attributes - added test for this * Moose::Meta::Class - handled the add_attribute($attribute_meta_object) case correctly - added test for this 0.35 Tues. Jan. 22, 2008 * Moose::Meta::Method::Constructor - fix to make sure even Class::MOP attributes are handled correctly (Thanks to Dave Rolsky) - added test for this (also Dave Rolsky) * Moose::Meta::Class - improved error message on _apply_all_roles, you should now use Moose::Util::apply_all_roles and you shouldnt have been using a _ prefixed method in the first place ;) 0.34 Mon. Jan. 21, 2008 ~~~ more misc. doc. fixes ~~~ ~~ updated copyright dates ~~ Moose is now a postmodern object system :) - (see the POD for details) * <> - this release contains a major reworking and cleanup of the role system - 100% backwards compat. - Role application now restructured into seperate classes based on type of applicants - Role summation (combining of more than one role) is much cleaner and anon-classes are no longer used in this process - new Composite role metaclass - runtime application of roles to instances is now more efficient and re-uses generated classes when applicable * <> - methods can now be excluded from a given role during composition - methods can now be aliased to another name (and still retain the original as well) * Moose::Util::TypeConstraints::OptimizedConstraints - added this module (see above) * Moose::Meta::Class - fixed the &_process_attribute method to be called by &add_attribute, so that the API is now correct * Moose::Meta::Method::Accessor - fixed bug when passing a list of values to an accessor would get (incorrectly) ignored. Thanks to Sartak for finding this ;) - added tests for this (Sartak again) * Moose::Meta::Method::Accessor Moose::Meta::Method::Constructor Moose::Meta::Attribute Moose::Meta::TypeConstraint Moose::Meta::TypeCoercion - lots of cleanup of such things as: - generated methods - type constraint handling - error handling/messages (thanks to nothingmuch) * Moose::Meta::TypeConstraint::Parameterizable - added this module to support the refactor in Moose::Meta::TypeConstraint::Parameterized * Moose::Meta::TypeConstraint::Parameterized - refactored how these types are handled so they are more generic and not confined to ArrayRef and HashRef only * t/ - shortened some file names for better VMS support (RT #32381) 0.33 Fri. Dec. 14, 2007 !! Moose now loads 2 x faster !! !! with new Class::MOP 0.49 !! ++ new oose.pm module to make command line Moose-ness easier (see POD docs for more) * Moose::Meta::Class * Moose::Meta::Role - several tweaks to take advantage of the new method map caching in Class::MOP * Moose::Meta::TypeConstraint::Parameterized - allow subtypes of ArrayRef and HashRef to be used as a container (sartak) - added tests for this - basic support for coercion to ArrayRef and HashRef for containers (sartak) - added tests for this * Moose::Meta::TypeCoercion - coercions will now create subtypes as needed so you can now add coercions to parameterized types without having to explictly define them - added tests for this * Moose::Meta::Method::Accessor - allow subclasses to decide whether we need to copy the value into a new variable (sartak) 0.32 Tues. Dec. 4, 2007 * Moose::Util::TypeConstraints - fixing how subtype aliases of unions work they should inherit the parent's coercion - added tests for this - you can now define multiple coercions on a single type at different times instead of having to do it all in one place - added tests for this * Moose::Meta::TypeConstraint - there is now a default constraint of sub { 1 } instead of Moose::Util::TypeConstraints setting this for us * Moose::Meta::TypeCoercion * Moose::Meta::TypeCoercion::Union - added the &has_coercion_for_type and &add_type_coercions methods to support the new features above (although you cannot add more type coercions for Union types) 0.31 Mon. Nov. 26, 2007 * Moose::Meta::Attribute - made the +attr syntax handle extending types with parameters. So "has '+foo' => (isa => 'ArrayRef[Int]')" now works if the original foo is an ArrayRef. - added tests for this. - delegation now works even if the attribute does not have a reader method using the get_read_method_ref method from Class::MOP::Attribute. - added tests for this - added docs for this * Moose::Util::TypeConstraints - passing no "additional attribute info" to &find_or_create_type_constraint will no longer attempt to create an __ANON__ type for you, instead it will just return undef. - added docs for this 0.30 Fri. Nov. 23, 2007 * Moose::Meta::Method::Constructor -builder related bug in inlined constructor. (groditi) * Moose::Meta::Method::Accessor - genereate unnecessary calls to predicates and refactor code generation for runtime speed (groditi) * Moose::Util::TypeConstraints - fix ClassName constraint to introspect symbol table (mst) - added more tests for this (mst) - fixed it so that subtype 'Foo' => as 'HashRef[Int]' ... with work correctly. - added tests for this * Moose::Cookbook - adding the link to Recipie 11 (written by Sartak) - adding test for SYNOPSIS code * t/ - New tests for builder bug. Upon instantiation, if an attribute had a builder, no value and was not lazy the builder default was not getting run, oops. (groditi) 0.29 Tues. Nov. 13, 2007 * Moose::Meta::Attribute - Fix error message on missing builder method (groditi) * Moose::Meta::Method::Accessor - Fix error message on missing builder method (groditi) * t/ - Add test to check for the correct error message when builder method is missing (groditi) 0.28 Tues. Nov. 13, 2007 - 0.27 packaged incorrectly (groditi) 0.27 Tues. Nov. 13, 2007 * Moose::Meta::Attribute - Added support for the new builder option (groditi) - Added support for lazy_build option (groditi) - Changed slot initialization for predicate changes (groditi) * Moose::Meta::Method::Accessor - Added support for lazy_build option (groditi) - Fix inline methods to work with corrected predicate behavior (groditi) * Moose::Meta::Method::Constructor - Added support for lazy_build option (groditi) * t/ - tests for builder and lazy_build (groditi) * fixing some misc. bits in the docs that got mentioned on CPAN Forum & perlmonks * Moose::Meta::Role - fixed how required methods are handled when they encounter overriden or modified methods from a class (thanks to confound). - added tests for this * Moose::Util::TypeConstraint - fixed the type notation parser so that the | always creates a union and so is no longer a valid type char (thanks to konobi, mugwump and #moose for working this one out.) - added more tests for this 0.26 Thurs. Sept. 27, 2007 == New Features == * Parameterized Types We now support parameterized collection types, such as: ArrayRef[Int] # array or integers HashRef[Object] # a hash with object values They can also be nested: ArrayRef[HashRef[RegexpRef]] # an array of hashes with regex values And work with the type unions as well: ArrayRef[Int | Str] # array of integers of strings * Better Framework Extendability Moose.pm is now "extendable" such that it is now much easier to extend the framework and add your own keywords and customizations. See the "EXTENDING AND EMBEDDING MOOSE" section of the Moose.pm docs. * Moose Snacks! In an effort to begin documenting some of the various details of Moose as well as some common idioms, we have created Moose::Cookbook::Snacks as a place to find small (easily digestable) nuggets of Moose code. ==== ~ Several doc updates/cleanup thanks to castaway ~ - converted build system to use Module::Install instead of Module::Build (thanks to jrockway) * Moose - added all the meta classes to the immutable list and set it to inline the accessors - fix import to allow Sub::Exporter like { into => } and { into_level => } (perigrin) - exposed and documented init_meta() to allow better embedding and extending of Moose (perigrin) * t/ - complete re-organization of the test suite - added some new tests as well - finally re-enabled the Moose::POOP test since the new version of DBM::Deep now works again (thanks rob) * Moose::Meta::Class - fixed very odd and very nasty recursion bug with inner/augment (mst) - added tests for this (eilara) * Moose::Meta::Attribute Moose::Meta::Method::Constructor Moose::Meta::Method::Accessor - fixed issue with overload::Overloaded getting called on non-blessed items. (RT #29269) - added tests for this * Moose::Meta::Method::Accessor - fixed issue with generated accessor code making assumptions about hash based classes (thanks to dexter) * Moose::Coookbook::Snacks - these are bits of documentation, not quite as big as Recipes but which have no clear place in the module docs. So they are Snacks! (horray for castaway++) * Moose::Cookbook::Recipe4 - updated it to use the new ArrayRef[MyType] construct - updated the accompanying test as well +++ Major Refactor of the Type Constraint system +++ +++ with new features added as well +++ * Moose::Util::TypeConstraint - no longer uses package variable to keep track of the type constraints, now uses the an instance of Moose::Meta::TypeConstraint::Registry to do it - added more sophisticated type notation parsing (thanks to mugwump) - added tests for this * Moose::Meta::TypeConstraint - some minor adjustments to make subclassing easier - added the package_defined_in attribute so that we can track where the type constraints are created * Moose::Meta::TypeConstraint::Union - this is now been refactored to be a subclass of Moose::Meta::TypeConstraint * Moose::Meta::TypeCoercion::Union - this has been added to service the newly refactored Moose::Meta::TypeConstraint::Union and is itself a subclass of Moose::Meta::TypeCoercion * Moose::Meta::TypeConstraint::Parameterized - added this module (taken from MooseX::AttributeHelpers) to help construct nested collection types - added tests for this * Moose::Meta::TypeConstraint::Registry - added this class to keep track of type constraints 0.25 Mon. Aug. 13, 2007 * Moose - Documentation update to reference Moose::Util::TypeConstraints under 'isa' in 'has' for how to define a new type (thanks to shlomif). * Moose::Meta::Attribute - required attributes now will no longer accept undef from the constructor, even if there is a default and lazy - added tests for this - default subroutines must return a value which passes the type constraint - added tests for this * Moose::Meta::Attribute * Moose::Meta::Method::Constructor * Moose::Meta::Method::Accessor - type-constraint tests now handle overloaded objects correctly in the error message - added tests for this (thanks to EvanCarroll) * Moose::Meta::TypeConstraint::Union - added (has_)hand_optimized_constraint to this class so that it behaves as the regular Moose::Meta::TypeConstraint does. * Moose::Meta::Role - large refactoring of this code - added several more tests - tests for subtle conflict resolition issues added, but not currently running (thanks to kolibre) * Moose::Cookbook::Recipe7 - added new recipe for augment/inner functionality (still in progress) - added test for this * Moose::Spec::Role - a formal definition of roles (still in progress) * Moose::Util - utilities for easier working with Moose classes - added tests for these * Test::Moose - This contains Moose specific test functions - added tests for these 0.24 Tues. July 3, 2007 ~ Some doc updates/cleanup ~ * Moose::Meta::Attribute - added support for roles to be given as parameters to the 'handles' option. - added tests and docs for this - the has '+foo' attribute form now accepts changes to the lazy option, and the addition of a handles option (but not changing the handles option) - added tests and docs for this * Moose::Meta::Role - required methods are now fetched using find_method_by_name so that required methods can come from superclasses - adjusted tests for this 0.23 Mon. June 18, 2007 * Moose::Meta::Method::Constructor - fix inlined constructor for hierarchy with multiple BUILD methods (mst) * Moose::Meta::Class - Modify make_immutable to work with the new Class::MOP immutable mechanism + POD + very basic test (groditi) * Moose::Meta::Attribute - Fix handles to use goto() so that caller() comes out properly on the other side (perigrin) 0.22 Thurs. May 31, 2007 * Moose::Util::TypeConstraints - fix for prototype undeclared issue when Moose::Util::TypeConstraints loaded before consumers (e.g. Moose::Meta::Attribute) by predeclaring prototypes for functions - added the ClassName type constraint, this checks for strings which will respond true to ->isa(UNIVERSAL). - added tests and docs for this - subtyping just in name now works correctly by making the default for where be { 1 } - added test for this * Moose::Meta::Method::Accessor - coerce and lazy now work together correctly, thanks to merlyn for finding this bug - tests added for this - fix reader presedence bug in Moose::Meta::Attribute + tests * Moose::Object - Foo->new(undef) now gets ignored, it is assumed you meant to pass a HASH-ref and missed. This produces better error messages then having it die cause undef is not a HASH. - added tests for this 0.21 Thursday, May 2nd, 2007 * Moose - added SUPER_SLOT and INNER_SLOT class hashes to support unimport - modified unimport to remove super and inner along with the rest - altered unimport tests to handle this * Moose::Role - altered super export to populate SUPER_SLOT * Moose::Meta::Class - altered augment and override modifier application to use *_SLOT - modified tests for these to unimport one test class each to test * Moose::Meta::Role - fixed issue where custom attribute metaclasses where not handled correctly in roles - added tests for this * Moose::Meta::Class - fixed issue where extending metaclasses with roles would blow up. Thanks to Aankhen`` for finding this insidious error, and it's solution. ~~ lots of spelling and grammer fixes in the docs, many many thanks to rlb3 and Aankhen for these :) 0.20 Friday, April 6th, 2007 >> I messed up the SKIP logic in one test so this release is just to fix that. * Moose - 'has' now also accepts an ARRAY ref to create multiple attrs (see docs) (thanks to konobi for this) - added tests and docs 0.19 Thurs. April 5th, 2007 ~~ More documentation updates ~~ * Moose::Util::TypeConstraints - 'type' now supports messages as well thanks to phaylon for finding this - added tests for this - added &list_all_type_constraints and &list_all_builtin_type_constraints functions to facilitate introspection. * Moose::Meta::Attribute - fixed regexp 'handles' declarations to build the list of delegated methods correctly (and not override important things like &new) thanks to ashleyb for finding this - added tests and docs for this - added the 'documentation' attributes so that you can actually document your attributes and inspect them through the meta-object. - added tests and docs for this * Moose::Meta::Class - when loading custom attribute metaclasses it will first look in for the class in the Moose::Meta::Attribute::Custom::$name, and then default to just loading $name. - added tests and docs for this * Moose::Meta::TypeConstraint - type constraints now stringify to their names. - added test for this * misc. - added tests to assure we work with Module::Refresh - added stricter test skip logic in the Moose POOP test, ask Rob Kinyon why. - *cough* DBM::Deep 1.0 backwards compatibility sucks *cough* ;) 0.18 Sat. March 10, 2007 ~~ Many, many documentation updates ~~ * misc. - We now use Class::MOP::load_class to load all classes. - added tests to show types and subtypes working with Declare::Constraints::Simple and Test::Deep as constraint engines. 0.18_001 !! You must have Class::MOP 0.37_001 !! !! for this developer release to work !! This release was primarily adding the immutable feature to Moose. An immutable class is one which you promise not to alter. When you set the class as immutable it will perform various bits of memoization and inline certain part of the code (constructors, destructors and accessors). This minimizes (and in some cases totally eliminates) one of Moose's biggest performance hits. This feature is not on by default, and is 100% optional. It has several configurable bits as well, so you can pick and choose to your specific needs. The changes involved in this were fairly wide and highly specific, but 100% backwards compatible, so I am not going to enumerate them here. If you are truely interested in what was changed, please do a diff :) 0.17 Tues. Nov. 14, 2006 * Moose::Meta::Method::Accessor - bugfix for read-only accessors which are have a type constraint and lazy. Thanks to chansen for finding it. 0.16 Tues. Nov. 14, 2006 ++ NOTE ++ There are some speed improvements in this release, but they are only the begining, so stay tuned. * Moose::Object - BUILDALL and DEMOLISHALL no longer get called unless they actually need to be. This gave us a signifigant speed boost for the cases when there is no BUILD or DEMOLISH method present. * Moose::Util::TypeConstraints * Moose::Meta::TypeConstraint - added an 'optimize_as' option to the type constraint, which allows for a hand optimized version of the type constraint to be used when possible. - Any internally created type constraints now provide an optimized version as well. 0.15 Sun. Nov. 5, 2006 ++ NOTE ++ This version of Moose *must* have Class::MOP 0.36 in order to work correctly. A number of small internal tweaks have been made in order to be compatible with that release. * Moose::Util::TypeConstraints - added &unimport so that you can clean out your class namespace of these exported keywords * Moose::Meta::Class - fixed minor issue which occasionally comes up during global destruction (thanks omega) - moved Moose::Meta::Method::Overriden into its own file. * Moose::Meta::Role - moved Moose::Meta::Role::Method into its own file. * Moose::Meta::Attribute - changed how we do type checks so that we reduce the overall cost, but still retain correctness. *** API CHANGE *** - moved accessor generation methods to Moose::Meta::Method::Accessor to conform to the API changes from Class::MOP 0.36 * Moose::Meta::TypeConstraint - changed how constraints are compiled so that we do less recursion and more iteration. This makes the type check faster :) - moved Moose::Meta::TypeConstraint::Union into its own file * Moose::Meta::Method::Accessor - created this from methods formerly found in Moose::Meta::Attribute * Moose::Meta::Role::Method - moved this from Moose::Meta::Role * Moose::Meta::Method::Overriden - moved this from Moose::Meta::Class * Moose::Meta::TypeConstraint::Union - moved this from Moose::Meta::TypeConstraint 0.14 Mon. Oct. 9, 2006 * Moose::Meta::Attribute - fixed lazy attributes which were not getting checked with the type constraint (thanks ashley) - added tests for this - removed the over-enthusiastic DWIMery of the automatic ArrayRef and HashRef defaults, it broke predicates in an ugly way. - removed tests for this 0.13 Sat. Sept. 30, 2006 ++ NOTE ++ This version of Moose *must* have Class::MOP 0.35 in order to work correctly. A number of small internal tweaks have been made in order to be compatible with that release. * Moose - Removed the use of UNIVERSAL::require to be a better symbol table citizen and remove a dependency (thanks Adam Kennedy) **~~ removed experimental & undocumented feature ~~** - commented out the 'method' and 'self' keywords, see the comments for more info. * Moose::Cookbook - added a FAQ and WTF files to document frequently asked questions and common problems * Moose::Util::TypeConstraints - added GlobRef and FileHandle type constraint - added tests for this * Moose::Meta::Attribute - if your attribute 'isa' ArrayRef of HashRef, and you have not explicitly set a default, then make the default DWIM. This will also work for subtypes of ArrayRef and HashRef as well. - you can now auto-deref subtypes of ArrayRef or HashRef too. - new test added for this (thanks to ashley) * Moose::Meta::Role - added basic support for runtime role composition but this is still *highly experimental*, so feedback is much appreciated :) - added tests for this * Moose::Meta::TypeConstraint - the type constraint now handles the coercion process through delegation, this is to support the coercion of unions * Moose::Meta::TypeConstraint::Union - it is now possible for coercions to be performed on a type union - added tests for this (thanks to konobi) * Moose::Meta::TypeCoercion - properly capturing error when type constraint is not found * Build.PL - Scalar::Util 1.18 is bad on Win32, so temporarily only require version 1.17 for Win32 and cygwin. (thanks Adam Kennedy) 0.12 Sat. Sept. 1, 2006 * Moose::Cookbook - Recipe5 (subtypes & coercion) has been written * Moose - fixed "bad meta" error message to be more descriptive - fixed &unimport to not remove the &inner and &super keywords because we need to localize them. - fixed number of spelling/grammer issues, thanks Theory :) **~~ experimental & undocumented feature ~~** - added the method and self keywords, they are basically just sugar, and they may not stay around. * Moose::Object - added &dump method to easily Data::Dumper an object * Moose::Meta::TypeConstraint - added the &is_a_type_of method to check both the current and the subtype of a method (similar to &isa with classes) * Moose::Meta::Role - this is now a subclass of Class::MOP::Module, and no longer creates the _role_meta ugliness of before. - fixed tests to reflect this change 0.11 Wed. July 12, 2006 * Moose - added an &unimport method to remove all the keywords that Moose will import, simply add 'no Moose' to the bottom of your class file. * t/ - fixed some test failures caused by a forgotten test dependency. 0.10 Thurs. July 6, 2006 * Moose - improved error message when loading modules so it is less confusing when you load a role. - added &calculate_all_roles method to Moose::Meta::Class and Moose::Meta::Role NOTE: This module has been tested against Class::MOP 0.30 but it does not yet utilize the optimizations it makes available. Stay tuned for that ;) 0.09_03 Fri. June 23, 2006 ++ DEVELOPER RELEASE ++ * Moose - 'use strict' and 'use warnings' are no longer needed in Moose classes, Moose itself will turn them on for you. - added tests for this - moved code from exported subs to private methods in Moose::Meta::Class * Moose::Role - as with Moose, strict and warnings are automatically turned on for you. - added tests for this * Moose::Meta::Role - now handles an edge case for override errors - added tests for this - added some more edge case tests 0.09_02 Tues. May 16, 2006 ++ DEVELOPER RELEASE ++ * Moose - added prototypes to the exported subs - updated docs * Moose::Role - added prototypes to the exported subs - updated docs * Moose::Util::TypeConstraints - cleaned up prototypes for the subs - updated docs 0.09_01 Fri. May 12, 2006 ++ DEVELOPER RELEASE ++ - This release works in combination with Class::MOP 0.29_01, it is a developer release because it uses the a new instance sub-protocol and a fairly complete Role implementation. It has not yet been optimized, so it slower the the previous CPAN version. This release also lacks good updated docs, the official release will have updated docs. * Moose - refactored the keyword exports - 'with' now checks Role validaity and accepts more than one Role at a time - 'extends' makes metaclass adjustments as needed to ensure metaclass compatibility * Moose::Role - refactored the keyword exports - 'with' now checks Role validaity and accepts more than one Role at a time * Moose::Util::TypeConstraints - added the 'enum' keyword for simple string enumerations which can be used as type constraints - see example of usage in t/202_example.t * Moose::Object - more careful checking of params to new() * Moose::Meta::Role - much work done on the role composition - many new tests for conflict detection and composition edge cases - not enough documentation, I suggest looking at the tests * Moose::Meta::Instance - added new Instance metaclass to support the new Class::MOP instance protocol * Moose::Meta::Class - some small changes to support the new instance protocol - some small additions to support Roles * Moose::Meta::Attribute - some improvements to the accessor generation code by nothingmuch - some small changes to support the new instance protocol - (still somewhat) experimental delegation support with the 'handles' option - added several tests for this - no docs for this yet 0.05 Thurs. April 27, 2006 * Moose - keywords are now exported with Sub::Exporter thanks to chansen for this commit - has keyword now takes a 'metaclass' option to support custom attribute meta-classes on a per-attribute basis - added tests for this - the 'has' keyword not accepts inherited slot specifications (has '+foo'). This is still an experimental feature and probably not finished see t/038_attribute_inherited_slot_specs.t for more details, or ask about it on #moose - added tests for this * Moose::Role - keywords are now exported with Sub::Exporter * Moose::Utils::TypeConstraints - reorganized the type constraint hierarchy, thanks to nothingmuch and chansen for his help and advice on this - added some tests for this - keywords are now exported with Sub::Exporter thanks to chansen for this commit * Moose::Meta::Class - due to changes in Class::MOP, we had to change construct_instance (for the better) * Moose::Meta::Attribute - due to changes in Class::MOP, we had to add the initialize_instance_slot method (it's a good thing) * Moose::Meta::TypeConstraint - added type constraint unions - added tests for this - added the is_subtype_of predicate method - added tests for this 0.04 Sun. April 16th, 2006 * Moose::Role - Roles can now consume other roles - added tests for this - Roles can specify required methods now with the requires() keyword - added tests for this * Moose::Meta::Role - ripped out much of it's guts ,.. much cleaner now - added required methods and correct handling of them in apply() for both classes and roles - added tests for this - no longer adds a does() method to consuming classes it relys on the one in Moose::Object - added roles attribute and some methods to support roles consuming roles * Moose::Meta::Attribute - added support for triggers on attributes - added tests for this - added support for does option on an attribute - added tests for this * Moose::Meta::Class - added support for attribute triggers in the object construction - added tests for this * Moose - Moose no longer creates a subtype for your class if a subtype of the same name already exists, this should DWIM in 99.9999% of all cases * Moose::Util::TypeConstraints - fixed bug where incorrect subtype conflicts were being reported - added test for this * Moose::Object - this class can now be extended with 'use base' if you need it, it properly loads the metaclass class now - added test for this 0.03_02 Wed. April 12, 2006 * Moose - you must now explictly use Moose::Util::TypeConstraints it no longer gets exported for you automatically * Moose::Object - new() now accepts hash-refs as well as key/value lists - added does() method to check for Roles - added tests for this * Moose::Meta::Class - added roles attribute along with the add_role() and does_role() methods - added tests for this * Moose::Meta::Role - now adds a does() method to consuming classes which tests the class's hierarchy for roles - added tests for this 0.03_01 Mon. April 10, 2006 * Moose::Cookbook - added new Role recipe (no content yet, only code) * Moose - added 'with' keyword for Role support - added test and docs for this - fixed subtype quoting bug - added test for this * Moose::Role - Roles for Moose - added test and docs * Moose::Util::TypeConstraints - added the message keyword to add custom error messages to type constraints * Moose::Meta::Role - the meta role to support Moose::Role - added tests and docs * Moose::Meta::Class - moved a number of things from Moose.pm to here, they should have been here in the first place * Moose::Meta::Attribute - moved the attribute option macros here instead of putting them in Moose.pm * Moose::Meta::TypeConstraint - added the message attributes and the validate method - added tests and docs for this 0.03 Thurs. March 30, 2006 * Moose::Cookbook - added the Moose::Cookbook with 5 recipes, describing all the stuff Moose can do. * Moose - fixed an issue with &extends super class loading it now captures errors and deals with inline packages correctly (bug found by mst, solution stolen from alias) - added super/override & inner/augment features - added tests and docs for these * Moose::Object - BUILDALL now takes a reference of the %params that are passed to &new, and passes that to each BUILD as well. * Moose::Util::TypeConstraints - Type constraints now survive runtime reloading - added test for this * Moose::Meta::Class - fixed the way attribute defaults are handled during instance construction (bug found by chansen) * Moose::Meta::Attribute - read-only attributes now actually enforce their read-only-ness (this corrected in Class::MOP as well) 0.02 Tues. March 21, 2006 * Moose - many more tests, fixing some bugs and edge cases - &extends now loads the base module with UNIVERSAL::require - added UNIVERSAL::require to the dependencies list ** API CHANGES ** - each new Moose class will also create and register a subtype of Object which correspond to the new Moose class. - the 'isa' option in &has now only accepts strings, and will DWIM in almost all cases * Moose::Util::TypeConstraints - added type coercion features - added tests for this - added support for this in attributes and instance construction ** API CHANGES ** - type construction no longer creates a function, it registers the type instead. - added several functions to get the registered types * Moose::Object - BUILDALL and DEMOLISHALL were broken because of a mis-named hash key, Whoops :) * Moose::Meta::Attribute - adding support for coercion in the autogenerated accessors * Moose::Meta::Class - adding support for coercion in the instance construction * Moose::Meta::TypeConstraint * Moose::Meta::TypeCoercion - type constraints and coercions are now full fledges meta-objects 0.01 Wed. March 15, 2006 - Moooooooooooooooooose!!! LICENSE100644000767000024 4372512200352344 13374 0ustar00etherstaff000000000000Moose-2.1005This software is copyright (c) 2013 by Infinity Interactive, Inc.. This is free software; you can redistribute it and/or modify it under the same terms as the Perl 5 programming language system itself. Terms of the Perl programming language system itself a) the GNU General Public License as published by the Free Software Foundation; either version 1, or (at your option) any later version, or b) the "Artistic License" --- The GNU General Public License, Version 1, February 1989 --- This software is Copyright (c) 2013 by Infinity Interactive, Inc.. This is free software, licensed under: The GNU General Public License, Version 1, February 1989 GNU GENERAL PUBLIC LICENSE Version 1, February 1989 Copyright (C) 1989 Free Software Foundation, Inc. 51 Franklin St, Suite 500, Boston, MA 02110-1335 USA Everyone is permitted to copy and distribute verbatim copies of this license document, but changing it is not allowed. Preamble The license agreements of most software companies try to keep users at the mercy of those companies. By contrast, our General Public License is intended to guarantee your freedom to share and change free software--to make sure the software is free for all its users. The General Public License applies to the Free Software Foundation's software and to any other program whose authors commit to using it. You can use it for your programs, too. When we speak of free software, we are referring to freedom, not price. Specifically, the General Public License is designed to make sure that you have the freedom to give away or sell copies of free software, that you receive source code or can get it if you want it, that you can change the software or use pieces of it in new free programs; and that you know you can do these things. To protect your rights, we need to make restrictions that forbid anyone to deny you these rights or to ask you to surrender the rights. These restrictions translate to certain responsibilities for you if you distribute copies of the software, or if you modify it. For example, if you distribute copies of a such a program, whether gratis or for a fee, you must give the recipients all the rights that you have. You must make sure that they, too, receive or can get the source code. And you must tell them their rights. We protect your rights with two steps: (1) copyright the software, and (2) offer you this license which gives you legal permission to copy, distribute and/or modify the software. Also, for each author's protection and ours, we want to make certain that everyone understands that there is no warranty for this free software. If the software is modified by someone else and passed on, we want its recipients to know that what they have is not the original, so that any problems introduced by others will not reflect on the original authors' reputations. The precise terms and conditions for copying, distribution and modification follow. GNU GENERAL PUBLIC LICENSE TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION 0. This License Agreement applies to any program or other work which contains a notice placed by the copyright holder saying it may be distributed under the terms of this General Public License. The "Program", below, refers to any such program or work, and a "work based on the Program" means either the Program or any work containing the Program or a portion of it, either verbatim or with modifications. Each licensee is addressed as "you". 1. You may copy and distribute verbatim copies of the Program's source code as you receive it, in any medium, provided that you conspicuously and appropriately publish on each copy an appropriate copyright notice and disclaimer of warranty; keep intact all the notices that refer to this General Public License and to the absence of any warranty; and give any other recipients of the Program a copy of this General Public License along with the Program. You may charge a fee for the physical act of transferring a copy. 2. You may modify your copy or copies of the Program or any portion of it, and copy and distribute such modifications under the terms of Paragraph 1 above, provided that you also do the following: a) cause the modified files to carry prominent notices stating that you changed the files and the date of any change; and b) cause the whole of any work that you distribute or publish, that in whole or in part contains the Program or any part thereof, either with or without modifications, to be licensed at no charge to all third parties under the terms of this General Public License (except that you may choose to grant warranty protection to some or all third parties, at your option). c) If the modified program normally reads commands interactively when run, you must cause it, when started running for such interactive use in the simplest and most usual way, to print or display an announcement including an appropriate copyright notice and a notice that there is no warranty (or else, saying that you provide a warranty) and that users may redistribute the program under these conditions, and telling the user how to view a copy of this General Public License. d) You may charge a fee for the physical act of transferring a copy, and you may at your option offer warranty protection in exchange for a fee. Mere aggregation of another independent work with the Program (or its derivative) on a volume of a storage or distribution medium does not bring the other work under the scope of these terms. 3. You may copy and distribute the Program (or a portion or derivative of it, under Paragraph 2) in object code or executable form under the terms of Paragraphs 1 and 2 above provided that you also do one of the following: a) accompany it with the complete corresponding machine-readable source code, which must be distributed under the terms of Paragraphs 1 and 2 above; or, b) accompany it with a written offer, valid for at least three years, to give any third party free (except for a nominal charge for the cost of distribution) a complete machine-readable copy of the corresponding source code, to be distributed under the terms of Paragraphs 1 and 2 above; or, c) accompany it with the information you received as to where the corresponding source code may be obtained. (This alternative is allowed only for noncommercial distribution and only if you received the program in object code or executable form alone.) Source code for a work means the preferred form of the work for making modifications to it. For an executable file, complete source code means all the source code for all modules it contains; but, as a special exception, it need not include source code for modules which are standard libraries that accompany the operating system on which the executable file runs, or for standard header files or definitions files that accompany that operating system. 4. You may not copy, modify, sublicense, distribute or transfer the Program except as expressly provided under this General Public License. Any attempt otherwise to copy, modify, sublicense, distribute or transfer the Program is void, and will automatically terminate your rights to use the Program under this License. However, parties who have received copies, or rights to use copies, from you under this General Public License will not have their licenses terminated so long as such parties remain in full compliance. 5. By copying, distributing or modifying the Program (or any work based on the Program) you indicate your acceptance of this license to do so, and all its terms and conditions. 6. Each time you redistribute the Program (or any work based on the Program), the recipient automatically receives a license from the original licensor to copy, distribute or modify the Program subject to these terms and conditions. You may not impose any further restrictions on the recipients' exercise of the rights granted herein. 7. The Free Software Foundation may publish revised and/or new versions of the General Public License from time to time. Such new versions will be similar in spirit to the present version, but may differ in detail to address new problems or concerns. Each version is given a distinguishing version number. If the Program specifies a version number of the license which applies to it and "any later version", you have the option of following the terms and conditions either of that version or of any later version published by the Free Software Foundation. If the Program does not specify a version number of the license, you may choose any version ever published by the Free Software Foundation. 8. If you wish to incorporate parts of the Program into other free programs whose distribution conditions are different, write to the author to ask for permission. For software which is copyrighted by the Free Software Foundation, write to the Free Software Foundation; we sometimes make exceptions for this. Our decision will be guided by the two goals of preserving the free status of all derivatives of our free software and of promoting the sharing and reuse of software generally. NO WARRANTY 9. BECAUSE THE PROGRAM IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY FOR THE PROGRAM, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE PROGRAM IS WITH YOU. SHOULD THE PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING, REPAIR OR CORRECTION. 10. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR REDISTRIBUTE THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER PROGRAMS), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGES. END OF TERMS AND CONDITIONS Appendix: How to Apply These Terms to Your New Programs If you develop a new program, and you want it to be of the greatest possible use to humanity, the best way to achieve this is to make it free software which everyone can redistribute and change under these terms. To do so, attach the following notices to the program. It is safest to attach them to the start of each source file to most effectively convey the exclusion of warranty; and each file should have at least the "copyright" line and a pointer to where the full notice is found. Copyright (C) 19yy This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 1, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program; if not, write to the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston MA 02110-1301 USA Also add information on how to contact you by electronic and paper mail. If the program is interactive, make it output a short notice like this when it starts in an interactive mode: Gnomovision version 69, Copyright (C) 19xx name of author Gnomovision comes with ABSOLUTELY NO WARRANTY; for details type `show w'. This is free software, and you are welcome to redistribute it under certain conditions; type `show c' for details. The hypothetical commands `show w' and `show c' should show the appropriate parts of the General Public License. Of course, the commands you use may be called something other than `show w' and `show c'; they could even be mouse-clicks or menu items--whatever suits your program. You should also get your employer (if you work as a programmer) or your school, if any, to sign a "copyright disclaimer" for the program, if necessary. Here a sample; alter the names: Yoyodyne, Inc., hereby disclaims all copyright interest in the program `Gnomovision' (a program to direct compilers to make passes at assemblers) written by James Hacker. , 1 April 1989 Ty Coon, President of Vice That's all there is to it! --- The Artistic License 1.0 --- This software is Copyright (c) 2013 by Infinity Interactive, Inc.. This is free software, licensed under: The Artistic License 1.0 The Artistic License Preamble The intent of this document is to state the conditions under which a Package may be copied, such that the Copyright Holder maintains some semblance of artistic control over the development of the package, while giving the users of the package the right to use and distribute the Package in a more-or-less customary fashion, plus the right to make reasonable modifications. Definitions: - "Package" refers to the collection of files distributed by the Copyright Holder, and derivatives of that collection of files created through textual modification. - "Standard Version" refers to such a Package if it has not been modified, or has been modified in accordance with the wishes of the Copyright Holder. - "Copyright Holder" is whoever is named in the copyright or copyrights for the package. - "You" is you, if you're thinking about copying or distributing this Package. - "Reasonable copying fee" is whatever you can justify on the basis of media cost, duplication charges, time of people involved, and so on. (You will not be required to justify it to the Copyright Holder, but only to the computing community at large as a market that must bear the fee.) - "Freely Available" means that no fee is charged for the item itself, though there may be fees involved in handling the item. It also means that recipients of the item may redistribute it under the same conditions they received it. 1. You may make and give away verbatim copies of the source form of the Standard Version of this Package without restriction, provided that you duplicate all of the original copyright notices and associated disclaimers. 2. You may apply bug fixes, portability fixes and other modifications derived from the Public Domain or from the Copyright Holder. A Package modified in such a way shall still be considered the Standard Version. 3. You may otherwise modify your copy of this Package in any way, provided that you insert a prominent notice in each changed file stating how and when you changed that file, and provided that you do at least ONE of the following: a) place your modifications in the Public Domain or otherwise make them Freely Available, such as by posting said modifications to Usenet or an equivalent medium, or placing the modifications on a major archive site such as ftp.uu.net, or by allowing the Copyright Holder to include your modifications in the Standard Version of the Package. b) use the modified Package only within your corporation or organization. c) rename any non-standard executables so the names do not conflict with standard executables, which must also be provided, and provide a separate manual page for each non-standard executable that clearly documents how it differs from the Standard Version. d) make other distribution arrangements with the Copyright Holder. 4. You may distribute the programs of this Package in object code or executable form, provided that you do at least ONE of the following: a) distribute a Standard Version of the executables and library files, together with instructions (in the manual page or equivalent) on where to get the Standard Version. b) accompany the distribution with the machine-readable source of the Package with your modifications. c) accompany any non-standard executables with their corresponding Standard Version executables, giving the non-standard executables non-standard names, and clearly documenting the differences in manual pages (or equivalent), together with instructions on where to get the Standard Version. d) make other distribution arrangements with the Copyright Holder. 5. You may charge a reasonable copying fee for any distribution of this Package. You may charge any fee you choose for support of this Package. You may not charge a fee for this Package itself. However, you may distribute this Package in aggregate with other (possibly commercial) programs as part of a larger (possibly commercial) software distribution provided that you do not advertise this Package as a product of your own. 6. The scripts and library files supplied as input to or produced as output from the programs of this Package do not automatically fall under the copyright of this Package, but belong to whomever generated them, and may be sold commercially, and may be aggregated with this Package. 7. C or perl subroutines supplied by you and linked into this Package shall not be considered part of this Package. 8. The name of the Copyright Holder may not be used to endorse or promote products derived from this software without specific prior written permission. 9. THIS PACKAGE IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED WARRANTIES OF MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE. The End dist.ini100644000767000024 1523112200352344 14022 0ustar00etherstaff000000000000Moose-2.1005name = Moose author = Moose is maintained by the Moose Cabal, along with the help of many contributors. See L and L for details. license = Perl_5 copyright_holder = Infinity Interactive, Inc. version = 2.1005 ; This sets the required version of Dist::Zilla :version = 4.200016 [=inc::RequireAuthorDeps] [=inc::Clean] [GatherDir] exclude_match = ^t/recipes/(?!basics_geonome_overloadingsubtypesandcoercion) [PruneCruft] [ManifestSkip] [MetaYAML] [MetaJSON] [License] [ExecDir] [ShareDir] ; authordep Dist::Zilla::Plugin::MakeMaker::Awesome [=inc::MakeMaker] [Manifest] [TestRelease] [UploadToCPAN] [NextRelease] format = %V %{ccc, MMM dd, yyyy}d [PruneFiles] filenames = Makefile.PL match = ^nytprof.* [PkgVersion] [MetaConfig] [Authority] authority = cpan:STEVAN [MetaResources] bugtracker.web = https://rt.cpan.org/Dist/Display.html?Name=Moose bugtracker.mailto = bug-moose@rt.cpan.org repository.url = git://github.com/moose/moose.git repository.web = https://github.com/moose/moose repository.type = git [MetaProvides::Package] meta_noindex = 1 [MetaNoIndex] package = Class::MOP::Class::Immutable::Trait package = Class::MOP::Deprecated package = Class::MOP::MiniTrait package = Class::MOP::Mixin namespace = Class::MOP::Mixin package = Moose::Deprecated package = Moose::Error::Util package = Moose::Meta::Attribute::Native::Trait package = Moose::Meta::Class::Immutable::Trait package = Moose::Meta::Method::Accessor::Native namespace = Moose::Meta::Method::Accessor::Native namespace = Moose::Meta::Mixin package = Moose::Meta::Object::Trait package = Moose::Util::TypeConstraints::OptimizedConstraints package = Moose::Util::TypeConstraints::Builtins directory = benchmarks ; XXX SurgicalPodWeaver doesn't specify its deps properly ([rt.cpan #87264]) ; authordep Dist::Zilla::Plugin::PodWeaver ; authordep Dist::Zilla::PluginBundle::ROKR [SurgicalPodWeaver] ; authordep Test::Inline ; authordep File::Find::Rule [=inc::ExtractInlineTests] [EOLTests] [PodSyntaxTests] [NoTabsTests] [RunExtraTests] ; FIXME: add back in when [Conflicts] and CPAN::Meta::Check are both fixed ; (and add conflicts entries for them!) [Test::CheckDeps] :version = 0.007 ; we may want to make this fatal in the future? fatal = 0 level = classic [Test::ChangesHasContent] ;[Test::NewVersion] [CheckChangesHasContent] ;[CheckPrereqsIndexed] [Prereqs] Carp = 1.22 Class::Load = 0.09 Class::Load::XS = 0.01 Data::OptList = 0.107 Devel::GlobalDestruction = 0 Eval::Closure = 0.04 List::MoreUtils = 0.28 MRO::Compat = 0.05 Package::DeprecationManager = 0.11 Package::Stash = 0.32 Package::Stash::XS = 0.24 Params::Util = 1.00 Scalar::Util = 1.19 Sub::Exporter = 0.980 Sub::Name = 0.05 Task::Weaken = 0 Try::Tiny = 0.02 perl = 5.8.3 [Prereqs / TestRequires] Test::Fatal = 0.001 Test::More = 0.88 Test::Requires = 0.05 ; indirect; remove when Test::CheckDeps bumps its prereq CPAN::Meta::Check = 0.007 [Prereqs / DevelopRequires] Algorithm::C3 = 0 Data::Visitor = 0 DateTime = 0 DateTime::Calendar::Mayan = 0 DateTime::Format::MySQL = 0 Declare::Constraints::Simple = 0 DBM::Deep = 0 File::Find::Rule = 0 HTTP::Headers = 0 IO::File = 0 IO::String = 0 Locale::US = 0 Module::Info = 0 Module::Refresh = 0 PadWalker = 0 Params::Coerce = 0 Regexp::Common = 0 SUPER = 0 Test::Deep = 0 Test::DependentModules = 0.13 Test::Inline = 0 Test::LeakTrace = 0 Test::Memory::Cycle = 0 Test::Output = 0 Test::Spelling = 0 URI = 0 Test::Inline::Extract = 0 ExtUtils::MakeMaker::Dist::Zilla::Develop = 0 MooseX::NonMoose = 0 Specio = 0.07 [Prereqs / RuntimeRecommends] ; this needs to be installed *after*, since it deps on Moose ; remove this if this is an issue Devel::PartialDump = 0.14 [Prereqs / DevelopConflicts] Dist::Zilla::Plugin::Conflicts = == 0.11 [Conflicts] -script = bin/moose-outdated Catalyst = 5.80028 Devel::REPL = 1.003008 Fey = 0.36 Fey::ORM = 0.42 File::ChangeNotify = 0.15 KiokuDB = 0.51 Markdent = 0.16 Mason = 2.18 MooseX::ABC = 0.05 MooseX::Aliases = 0.08 MooseX::AlwaysCoerce = 0.13 MooseX::App = 1.18 MooseX::AttributeHelpers = 0.22 MooseX::AttributeIndexes = 1.0.0 MooseX::AttributeInflate = 0.02 MooseX::Attribute::Deflator = 2.1.7 MooseX::Attribute::Dependent = 1.1.0 MooseX::Attribute::Prototype = 0.10 MooseX::CascadeClearing = 0.03 MooseX::ClassAttribute = 0.26 MooseX::Constructor::AllErrors = 0.012 MooseX::FollowPBP = 0.02 MooseX::HasDefaults = 0.02 MooseX::InstanceTracking = 0.04 MooseX::LazyRequire = 0.06 MooseX::Meta::Attribute::Index = 0.04 MooseX::Meta::Attribute::Lvalue = 0.05 MooseX::MethodAttributes = 0.22 MooseX::NonMoose = 0.17 MooseX::Params::Validate = 0.05 MooseX::PrivateSetters = 0.03 MooseX::POE = 0.214 MooseX::Role::Cmd = 0.06 MooseX::Role::Parameterized = 0.23 MooseX::Role::WithOverloading = 0.07 MooseX::Scaffold = 0.05 MooseX::SemiAffordanceAccessor = 0.05 MooseX::SetOnce = 0.100473 MooseX::Singleton = 0.25 MooseX::SlurpyConstructor = 1.1 MooseX::StrictConstructor = 0.12 MooseX::Types = 0.19 MooseX::Types::Parameterizable = 0.05 MooseX::Types::Signal = 1.101930 MooseX::UndefTolerant = 0.11 namespace::autoclean = 0.08 PRANG = 0.14 Pod::Elemental = 0.093280 Reaction = 0.002003 Test::Able = 0.10 [=inc::CheckDelta] [=inc::GitUpToDate] [Git::Remote::Check] branch = stable/2.10 remote_branch = stable/2.10 [Git::CheckFor::CorrectBranch] release_branch = stable/2.10 [Git::Check] allow_dirty = [ConfirmRelease] [Git::Commit] allow_dirty = Changes commit_msg = changelog for %N-%v%t [Git::Tag] tag_format = %v tag_message = %v%t [Git::Push] ppport.h100600000767000024 52540612200352344 14075 0ustar00etherstaff000000000000Moose-2.1005#if 0 <<'SKIP'; #endif /* ---------------------------------------------------------------------- ppport.h -- Perl/Pollution/Portability Version 3.19 Automatically created by Devel::PPPort running under perl 5.010001. Do NOT edit this file directly! -- Edit PPPort_pm.PL and the includes in parts/inc/ instead. Use 'perldoc ppport.h' to view the documentation below. ---------------------------------------------------------------------- SKIP =pod =head1 NAME ppport.h - Perl/Pollution/Portability version 3.19 =head1 SYNOPSIS perl ppport.h [options] [source files] Searches current directory for files if no [source files] are given --help show short help --version show version --patch=file write one patch file with changes --copy=suffix write changed copies with suffix --diff=program use diff program and options --compat-version=version provide compatibility with Perl version --cplusplus accept C++ comments --quiet don't output anything except fatal errors --nodiag don't show diagnostics --nohints don't show hints --nochanges don't suggest changes --nofilter don't filter input files --strip strip all script and doc functionality from ppport.h --list-provided list provided API --list-unsupported list unsupported API --api-info=name show Perl API portability information =head1 COMPATIBILITY This version of F is designed to support operation with Perl installations back to 5.003, and has been tested up to 5.10.0. =head1 OPTIONS =head2 --help Display a brief usage summary. =head2 --version Display the version of F. =head2 --patch=I If this option is given, a single patch file will be created if any changes are suggested. This requires a working diff program to be installed on your system. =head2 --copy=I If this option is given, a copy of each file will be saved with the given suffix that contains the suggested changes. This does not require any external programs. Note that this does not automagially add a dot between the original filename and the suffix. If you want the dot, you have to include it in the option argument. If neither C<--patch> or C<--copy> are given, the default is to simply print the diffs for each file. This requires either C or a C program to be installed. =head2 --diff=I Manually set the diff program and options to use. The default is to use C, when installed, and output unified context diffs. =head2 --compat-version=I Tell F to check for compatibility with the given Perl version. The default is to check for compatibility with Perl version 5.003. You can use this option to reduce the output of F if you intend to be backward compatible only down to a certain Perl version. =head2 --cplusplus Usually, F will detect C++ style comments and replace them with C style comments for portability reasons. Using this option instructs F to leave C++ comments untouched. =head2 --quiet Be quiet. Don't print anything except fatal errors. =head2 --nodiag Don't output any diagnostic messages. Only portability alerts will be printed. =head2 --nohints Don't output any hints. Hints often contain useful portability notes. Warnings will still be displayed. =head2 --nochanges Don't suggest any changes. Only give diagnostic output and hints unless these are also deactivated. =head2 --nofilter Don't filter the list of input files. By default, files not looking like source code (i.e. not *.xs, *.c, *.cc, *.cpp or *.h) are skipped. =head2 --strip Strip all script and documentation functionality from F. This reduces the size of F dramatically and may be useful if you want to include F in smaller modules without increasing their distribution size too much. The stripped F will have a C<--unstrip> option that allows you to undo the stripping, but only if an appropriate C module is installed. =head2 --list-provided Lists the API elements for which compatibility is provided by F. Also lists if it must be explicitly requested, if it has dependencies, and if there are hints or warnings for it. =head2 --list-unsupported Lists the API elements that are known not to be supported by F and below which version of Perl they probably won't be available or work. =head2 --api-info=I Show portability information for API elements matching I. If I is surrounded by slashes, it is interpreted as a regular expression. =head1 DESCRIPTION In order for a Perl extension (XS) module to be as portable as possible across differing versions of Perl itself, certain steps need to be taken. =over 4 =item * Including this header is the first major one. This alone will give you access to a large part of the Perl API that hasn't been available in earlier Perl releases. Use perl ppport.h --list-provided to see which API elements are provided by ppport.h. =item * You should avoid using deprecated parts of the API. For example, using global Perl variables without the C prefix is deprecated. Also, some API functions used to have a C prefix. Using this form is also deprecated. You can safely use the supported API, as F will provide wrappers for older Perl versions. =item * If you use one of a few functions or variables that were not present in earlier versions of Perl, and that can't be provided using a macro, you have to explicitly request support for these functions by adding one or more C<#define>s in your source code before the inclusion of F. These functions or variables will be marked C in the list shown by C<--list-provided>. Depending on whether you module has a single or multiple files that use such functions or variables, you want either C or global variants. For a C function or variable (used only in a single source file), use: #define NEED_function #define NEED_variable For a global function or variable (used in multiple source files), use: #define NEED_function_GLOBAL #define NEED_variable_GLOBAL Note that you mustn't have more than one global request for the same function or variable in your project. Function / Variable Static Request Global Request ----------------------------------------------------------------------------------------- PL_parser NEED_PL_parser NEED_PL_parser_GLOBAL PL_signals NEED_PL_signals NEED_PL_signals_GLOBAL eval_pv() NEED_eval_pv NEED_eval_pv_GLOBAL grok_bin() NEED_grok_bin NEED_grok_bin_GLOBAL grok_hex() NEED_grok_hex NEED_grok_hex_GLOBAL grok_number() NEED_grok_number NEED_grok_number_GLOBAL grok_numeric_radix() NEED_grok_numeric_radix NEED_grok_numeric_radix_GLOBAL grok_oct() NEED_grok_oct NEED_grok_oct_GLOBAL load_module() NEED_load_module NEED_load_module_GLOBAL my_snprintf() NEED_my_snprintf NEED_my_snprintf_GLOBAL my_sprintf() NEED_my_sprintf NEED_my_sprintf_GLOBAL my_strlcat() NEED_my_strlcat NEED_my_strlcat_GLOBAL my_strlcpy() NEED_my_strlcpy NEED_my_strlcpy_GLOBAL newCONSTSUB() NEED_newCONSTSUB NEED_newCONSTSUB_GLOBAL newRV_noinc() NEED_newRV_noinc NEED_newRV_noinc_GLOBAL newSV_type() NEED_newSV_type NEED_newSV_type_GLOBAL newSVpvn_flags() NEED_newSVpvn_flags NEED_newSVpvn_flags_GLOBAL newSVpvn_share() NEED_newSVpvn_share NEED_newSVpvn_share_GLOBAL pv_display() NEED_pv_display NEED_pv_display_GLOBAL pv_escape() NEED_pv_escape NEED_pv_escape_GLOBAL pv_pretty() NEED_pv_pretty NEED_pv_pretty_GLOBAL sv_2pv_flags() NEED_sv_2pv_flags NEED_sv_2pv_flags_GLOBAL sv_2pvbyte() NEED_sv_2pvbyte NEED_sv_2pvbyte_GLOBAL sv_catpvf_mg() NEED_sv_catpvf_mg NEED_sv_catpvf_mg_GLOBAL sv_catpvf_mg_nocontext() NEED_sv_catpvf_mg_nocontext NEED_sv_catpvf_mg_nocontext_GLOBAL sv_pvn_force_flags() NEED_sv_pvn_force_flags NEED_sv_pvn_force_flags_GLOBAL sv_setpvf_mg() NEED_sv_setpvf_mg NEED_sv_setpvf_mg_GLOBAL sv_setpvf_mg_nocontext() NEED_sv_setpvf_mg_nocontext NEED_sv_setpvf_mg_nocontext_GLOBAL vload_module() NEED_vload_module NEED_vload_module_GLOBAL vnewSVpvf() NEED_vnewSVpvf NEED_vnewSVpvf_GLOBAL warner() NEED_warner NEED_warner_GLOBAL To avoid namespace conflicts, you can change the namespace of the explicitly exported functions / variables using the C macro. Just C<#define> the macro before including C: #define DPPP_NAMESPACE MyOwnNamespace_ #include "ppport.h" The default namespace is C. =back The good thing is that most of the above can be checked by running F on your source code. See the next section for details. =head1 EXAMPLES To verify whether F is needed for your module, whether you should make any changes to your code, and whether any special defines should be used, F can be run as a Perl script to check your source code. Simply say: perl ppport.h The result will usually be a list of patches suggesting changes that should at least be acceptable, if not necessarily the most efficient solution, or a fix for all possible problems. If you know that your XS module uses features only available in newer Perl releases, if you're aware that it uses C++ comments, and if you want all suggestions as a single patch file, you could use something like this: perl ppport.h --compat-version=5.6.0 --cplusplus --patch=test.diff If you only want your code to be scanned without any suggestions for changes, use: perl ppport.h --nochanges You can specify a different C program or options, using the C<--diff> option: perl ppport.h --diff='diff -C 10' This would output context diffs with 10 lines of context. If you want to create patched copies of your files instead, use: perl ppport.h --copy=.new To display portability information for the C function, use: perl ppport.h --api-info=newSVpvn Since the argument to C<--api-info> can be a regular expression, you can use perl ppport.h --api-info=/_nomg$/ to display portability information for all C<_nomg> functions or perl ppport.h --api-info=/./ to display information for all known API elements. =head1 BUGS If this version of F is causing failure during the compilation of this module, please check if newer versions of either this module or C are available on CPAN before sending a bug report. If F was generated using the latest version of C and is causing failure of this module, please file a bug report using the CPAN Request Tracker at L. Please include the following information: =over 4 =item 1. The complete output from running "perl -V" =item 2. This file. =item 3. The name and version of the module you were trying to build. =item 4. A full log of the build that failed. =item 5. Any other information that you think could be relevant. =back For the latest version of this code, please get the C module from CPAN. =head1 COPYRIGHT Version 3.x, Copyright (c) 2004-2009, Marcus Holland-Moritz. Version 2.x, Copyright (C) 2001, Paul Marquess. Version 1.x, Copyright (C) 1999, Kenneth Albanowski. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =head1 SEE ALSO See L. =cut use strict; # Disable broken TRIE-optimization BEGIN { eval '${^RE_TRIE_MAXBUF} = -1' if $] >= 5.009004 && $] <= 5.009005 } my $VERSION = 3.19; my %opt = ( quiet => 0, diag => 1, hints => 1, changes => 1, cplusplus => 0, filter => 1, strip => 0, version => 0, ); my($ppport) = $0 =~ /([\w.]+)$/; my $LF = '(?:\r\n|[\r\n])'; # line feed my $HS = "[ \t]"; # horizontal whitespace # Never use C comments in this file! my $ccs = '/'.'*'; my $cce = '*'.'/'; my $rccs = quotemeta $ccs; my $rcce = quotemeta $cce; eval { require Getopt::Long; Getopt::Long::GetOptions(\%opt, qw( help quiet diag! filter! hints! changes! cplusplus strip version patch=s copy=s diff=s compat-version=s list-provided list-unsupported api-info=s )) or usage(); }; if ($@ and grep /^-/, @ARGV) { usage() if "@ARGV" =~ /^--?h(?:elp)?$/; die "Getopt::Long not found. Please don't use any options.\n"; } if ($opt{version}) { print "This is $0 $VERSION.\n"; exit 0; } usage() if $opt{help}; strip() if $opt{strip}; if (exists $opt{'compat-version'}) { my($r,$v,$s) = eval { parse_version($opt{'compat-version'}) }; if ($@) { die "Invalid version number format: '$opt{'compat-version'}'\n"; } die "Only Perl 5 is supported\n" if $r != 5; die "Invalid version number: $opt{'compat-version'}\n" if $v >= 1000 || $s >= 1000; $opt{'compat-version'} = sprintf "%d.%03d%03d", $r, $v, $s; } else { $opt{'compat-version'} = 5; } my %API = map { /^(\w+)\|([^|]*)\|([^|]*)\|(\w*)$/ ? ( $1 => { ($2 ? ( base => $2 ) : ()), ($3 ? ( todo => $3 ) : ()), (index($4, 'v') >= 0 ? ( varargs => 1 ) : ()), (index($4, 'p') >= 0 ? ( provided => 1 ) : ()), (index($4, 'n') >= 0 ? ( nothxarg => 1 ) : ()), } ) : die "invalid spec: $_" } qw( AvFILLp|5.004050||p AvFILL||| CLASS|||n CPERLscope|5.005000||p CX_CURPAD_SAVE||| CX_CURPAD_SV||| CopFILEAV|5.006000||p CopFILEGV_set|5.006000||p CopFILEGV|5.006000||p CopFILESV|5.006000||p CopFILE_set|5.006000||p CopFILE|5.006000||p CopSTASHPV_set|5.006000||p CopSTASHPV|5.006000||p CopSTASH_eq|5.006000||p CopSTASH_set|5.006000||p CopSTASH|5.006000||p CopyD|5.009002||p Copy||| CvPADLIST||| CvSTASH||| CvWEAKOUTSIDE||| DEFSV_set|5.011000||p DEFSV|5.004050||p END_EXTERN_C|5.005000||p ENTER||| ERRSV|5.004050||p EXTEND||| EXTERN_C|5.005000||p F0convert|||n FREETMPS||| GIMME_V||5.004000|n GIMME|||n GROK_NUMERIC_RADIX|5.007002||p G_ARRAY||| G_DISCARD||| G_EVAL||| G_METHOD|5.006001||p G_NOARGS||| G_SCALAR||| G_VOID||5.004000| GetVars||| GvSVn|5.009003||p GvSV||| Gv_AMupdate||| HEf_SVKEY||5.004000| HeHASH||5.004000| HeKEY||5.004000| HeKLEN||5.004000| HePV||5.004000| HeSVKEY_force||5.004000| HeSVKEY_set||5.004000| HeSVKEY||5.004000| HeUTF8||5.011000| HeVAL||5.004000| HvNAMELEN_get|5.009003||p HvNAME_get|5.009003||p HvNAME||| INT2PTR|5.006000||p IN_LOCALE_COMPILETIME|5.007002||p IN_LOCALE_RUNTIME|5.007002||p IN_LOCALE|5.007002||p IN_PERL_COMPILETIME|5.008001||p IS_NUMBER_GREATER_THAN_UV_MAX|5.007002||p IS_NUMBER_INFINITY|5.007002||p IS_NUMBER_IN_UV|5.007002||p IS_NUMBER_NAN|5.007003||p IS_NUMBER_NEG|5.007002||p IS_NUMBER_NOT_INT|5.007002||p IVSIZE|5.006000||p IVTYPE|5.006000||p IVdf|5.006000||p LEAVE||| LVRET||| MARK||| MULTICALL||5.011000| MY_CXT_CLONE|5.009002||p MY_CXT_INIT|5.007003||p MY_CXT|5.007003||p MoveD|5.009002||p Move||| NOOP|5.005000||p NUM2PTR|5.006000||p NVTYPE|5.006000||p NVef|5.006001||p NVff|5.006001||p NVgf|5.006001||p Newxc|5.009003||p Newxz|5.009003||p Newx|5.009003||p Nullav||| Nullch||| Nullcv||| Nullhv||| Nullsv||| ORIGMARK||| PAD_BASE_SV||| PAD_CLONE_VARS||| PAD_COMPNAME_FLAGS||| PAD_COMPNAME_GEN_set||| PAD_COMPNAME_GEN||| PAD_COMPNAME_OURSTASH||| PAD_COMPNAME_PV||| PAD_COMPNAME_TYPE||| PAD_DUP||| PAD_RESTORE_LOCAL||| PAD_SAVE_LOCAL||| PAD_SAVE_SETNULLPAD||| PAD_SETSV||| PAD_SET_CUR_NOSAVE||| PAD_SET_CUR||| PAD_SVl||| PAD_SV||| PERLIO_FUNCS_CAST|5.009003||p PERLIO_FUNCS_DECL|5.009003||p PERL_ABS|5.008001||p PERL_BCDVERSION|5.011000||p PERL_GCC_BRACE_GROUPS_FORBIDDEN|5.008001||p PERL_HASH|5.004000||p PERL_INT_MAX|5.004000||p PERL_INT_MIN|5.004000||p PERL_LONG_MAX|5.004000||p PERL_LONG_MIN|5.004000||p PERL_MAGIC_arylen|5.007002||p PERL_MAGIC_backref|5.007002||p PERL_MAGIC_bm|5.007002||p PERL_MAGIC_collxfrm|5.007002||p PERL_MAGIC_dbfile|5.007002||p PERL_MAGIC_dbline|5.007002||p PERL_MAGIC_defelem|5.007002||p PERL_MAGIC_envelem|5.007002||p PERL_MAGIC_env|5.007002||p PERL_MAGIC_ext|5.007002||p PERL_MAGIC_fm|5.007002||p PERL_MAGIC_glob|5.011000||p PERL_MAGIC_isaelem|5.007002||p PERL_MAGIC_isa|5.007002||p PERL_MAGIC_mutex|5.011000||p PERL_MAGIC_nkeys|5.007002||p PERL_MAGIC_overload_elem|5.007002||p PERL_MAGIC_overload_table|5.007002||p PERL_MAGIC_overload|5.007002||p PERL_MAGIC_pos|5.007002||p PERL_MAGIC_qr|5.007002||p PERL_MAGIC_regdata|5.007002||p PERL_MAGIC_regdatum|5.007002||p PERL_MAGIC_regex_global|5.007002||p PERL_MAGIC_shared_scalar|5.007003||p PERL_MAGIC_shared|5.007003||p PERL_MAGIC_sigelem|5.007002||p PERL_MAGIC_sig|5.007002||p PERL_MAGIC_substr|5.007002||p PERL_MAGIC_sv|5.007002||p PERL_MAGIC_taint|5.007002||p PERL_MAGIC_tiedelem|5.007002||p PERL_MAGIC_tiedscalar|5.007002||p PERL_MAGIC_tied|5.007002||p PERL_MAGIC_utf8|5.008001||p PERL_MAGIC_uvar_elem|5.007003||p PERL_MAGIC_uvar|5.007002||p PERL_MAGIC_vec|5.007002||p PERL_MAGIC_vstring|5.008001||p PERL_PV_ESCAPE_ALL|5.009004||p PERL_PV_ESCAPE_FIRSTCHAR|5.009004||p PERL_PV_ESCAPE_NOBACKSLASH|5.009004||p PERL_PV_ESCAPE_NOCLEAR|5.009004||p PERL_PV_ESCAPE_QUOTE|5.009004||p PERL_PV_ESCAPE_RE|5.009005||p PERL_PV_ESCAPE_UNI_DETECT|5.009004||p PERL_PV_ESCAPE_UNI|5.009004||p PERL_PV_PRETTY_DUMP|5.009004||p PERL_PV_PRETTY_ELLIPSES|5.010000||p PERL_PV_PRETTY_LTGT|5.009004||p PERL_PV_PRETTY_NOCLEAR|5.010000||p PERL_PV_PRETTY_QUOTE|5.009004||p PERL_PV_PRETTY_REGPROP|5.009004||p PERL_QUAD_MAX|5.004000||p PERL_QUAD_MIN|5.004000||p PERL_REVISION|5.006000||p PERL_SCAN_ALLOW_UNDERSCORES|5.007003||p PERL_SCAN_DISALLOW_PREFIX|5.007003||p PERL_SCAN_GREATER_THAN_UV_MAX|5.007003||p PERL_SCAN_SILENT_ILLDIGIT|5.008001||p PERL_SHORT_MAX|5.004000||p PERL_SHORT_MIN|5.004000||p PERL_SIGNALS_UNSAFE_FLAG|5.008001||p PERL_SUBVERSION|5.006000||p PERL_SYS_INIT3||5.006000| PERL_SYS_INIT||| PERL_SYS_TERM||5.011000| PERL_UCHAR_MAX|5.004000||p PERL_UCHAR_MIN|5.004000||p PERL_UINT_MAX|5.004000||p PERL_UINT_MIN|5.004000||p PERL_ULONG_MAX|5.004000||p PERL_ULONG_MIN|5.004000||p PERL_UNUSED_ARG|5.009003||p PERL_UNUSED_CONTEXT|5.009004||p PERL_UNUSED_DECL|5.007002||p PERL_UNUSED_VAR|5.007002||p PERL_UQUAD_MAX|5.004000||p PERL_UQUAD_MIN|5.004000||p PERL_USE_GCC_BRACE_GROUPS|5.009004||p PERL_USHORT_MAX|5.004000||p PERL_USHORT_MIN|5.004000||p PERL_VERSION|5.006000||p PL_DBsignal|5.005000||p PL_DBsingle|||pn PL_DBsub|||pn PL_DBtrace|||pn PL_Sv|5.005000||p PL_bufend|5.011000||p PL_bufptr|5.011000||p PL_compiling|5.004050||p PL_copline|5.011000||p PL_curcop|5.004050||p PL_curstash|5.004050||p PL_debstash|5.004050||p PL_defgv|5.004050||p PL_diehook|5.004050||p PL_dirty|5.004050||p PL_dowarn|||pn PL_errgv|5.004050||p PL_error_count|5.011000||p PL_expect|5.011000||p PL_hexdigit|5.005000||p PL_hints|5.005000||p PL_in_my_stash|5.011000||p PL_in_my|5.011000||p PL_last_in_gv|||n PL_laststatval|5.005000||p PL_lex_state|5.011000||p PL_lex_stuff|5.011000||p PL_linestr|5.011000||p PL_modglobal||5.005000|n PL_na|5.004050||pn PL_no_modify|5.006000||p PL_ofsgv|||n PL_parser|5.009005||p PL_perl_destruct_level|5.004050||p PL_perldb|5.004050||p PL_ppaddr|5.006000||p PL_rsfp_filters|5.004050||p PL_rsfp|5.004050||p PL_rs|||n PL_signals|5.008001||p PL_stack_base|5.004050||p PL_stack_sp|5.004050||p PL_statcache|5.005000||p PL_stdingv|5.004050||p PL_sv_arenaroot|5.004050||p PL_sv_no|5.004050||pn PL_sv_undef|5.004050||pn PL_sv_yes|5.004050||pn PL_tainted|5.004050||p PL_tainting|5.004050||p PL_tokenbuf|5.011000||p POP_MULTICALL||5.011000| POPi|||n POPl|||n POPn|||n POPpbytex||5.007001|n POPpx||5.005030|n POPp|||n POPs|||n PTR2IV|5.006000||p PTR2NV|5.006000||p PTR2UV|5.006000||p PTR2nat|5.009003||p PTR2ul|5.007001||p PTRV|5.006000||p PUSHMARK||| PUSH_MULTICALL||5.011000| PUSHi||| PUSHmortal|5.009002||p PUSHn||| PUSHp||| PUSHs||| PUSHu|5.004000||p PUTBACK||| PerlIO_clearerr||5.007003| PerlIO_close||5.007003| PerlIO_context_layers||5.009004| PerlIO_eof||5.007003| PerlIO_error||5.007003| PerlIO_fileno||5.007003| PerlIO_fill||5.007003| PerlIO_flush||5.007003| PerlIO_get_base||5.007003| PerlIO_get_bufsiz||5.007003| PerlIO_get_cnt||5.007003| PerlIO_get_ptr||5.007003| PerlIO_read||5.007003| PerlIO_seek||5.007003| PerlIO_set_cnt||5.007003| PerlIO_set_ptrcnt||5.007003| PerlIO_setlinebuf||5.007003| PerlIO_stderr||5.007003| PerlIO_stdin||5.007003| PerlIO_stdout||5.007003| PerlIO_tell||5.007003| PerlIO_unread||5.007003| PerlIO_write||5.007003| Perl_signbit||5.009005|n PoisonFree|5.009004||p PoisonNew|5.009004||p PoisonWith|5.009004||p Poison|5.008000||p RETVAL|||n Renewc||| Renew||| SAVECLEARSV||| SAVECOMPPAD||| SAVEPADSV||| SAVETMPS||| SAVE_DEFSV|5.004050||p SPAGAIN||| SP||| START_EXTERN_C|5.005000||p START_MY_CXT|5.007003||p STMT_END|||p STMT_START|||p STR_WITH_LEN|5.009003||p ST||| SV_CONST_RETURN|5.009003||p SV_COW_DROP_PV|5.008001||p SV_COW_SHARED_HASH_KEYS|5.009005||p SV_GMAGIC|5.007002||p SV_HAS_TRAILING_NUL|5.009004||p SV_IMMEDIATE_UNREF|5.007001||p SV_MUTABLE_RETURN|5.009003||p SV_NOSTEAL|5.009002||p SV_SMAGIC|5.009003||p SV_UTF8_NO_ENCODING|5.008001||p SVfARG|5.009005||p SVf_UTF8|5.006000||p SVf|5.006000||p SVt_IV||| SVt_NV||| SVt_PVAV||| SVt_PVCV||| SVt_PVHV||| SVt_PVMG||| SVt_PV||| Safefree||| Slab_Alloc||| Slab_Free||| Slab_to_rw||| StructCopy||| SvCUR_set||| SvCUR||| SvEND||| SvGAMAGIC||5.006001| SvGETMAGIC|5.004050||p SvGROW||| SvIOK_UV||5.006000| SvIOK_notUV||5.006000| SvIOK_off||| SvIOK_only_UV||5.006000| SvIOK_only||| SvIOK_on||| SvIOKp||| SvIOK||| SvIVX||| SvIV_nomg|5.009001||p SvIV_set||| SvIVx||| SvIV||| SvIsCOW_shared_hash||5.008003| SvIsCOW||5.008003| SvLEN_set||| SvLEN||| SvLOCK||5.007003| SvMAGIC_set|5.009003||p SvNIOK_off||| SvNIOKp||| SvNIOK||| SvNOK_off||| SvNOK_only||| SvNOK_on||| SvNOKp||| SvNOK||| SvNVX||| SvNV_set||| SvNVx||| SvNV||| SvOK||| SvOOK_offset||5.011000| SvOOK||| SvPOK_off||| SvPOK_only_UTF8||5.006000| SvPOK_only||| SvPOK_on||| SvPOKp||| SvPOK||| SvPVX_const|5.009003||p SvPVX_mutable|5.009003||p SvPVX||| SvPV_const|5.009003||p SvPV_flags_const_nolen|5.009003||p SvPV_flags_const|5.009003||p SvPV_flags_mutable|5.009003||p SvPV_flags|5.007002||p SvPV_force_flags_mutable|5.009003||p SvPV_force_flags_nolen|5.009003||p SvPV_force_flags|5.007002||p SvPV_force_mutable|5.009003||p SvPV_force_nolen|5.009003||p SvPV_force_nomg_nolen|5.009003||p SvPV_force_nomg|5.007002||p SvPV_force|||p SvPV_mutable|5.009003||p SvPV_nolen_const|5.009003||p SvPV_nolen|5.006000||p SvPV_nomg_const_nolen|5.009003||p SvPV_nomg_const|5.009003||p SvPV_nomg|5.007002||p SvPV_renew|5.009003||p SvPV_set||| SvPVbyte_force||5.009002| SvPVbyte_nolen||5.006000| SvPVbytex_force||5.006000| SvPVbytex||5.006000| SvPVbyte|5.006000||p SvPVutf8_force||5.006000| SvPVutf8_nolen||5.006000| SvPVutf8x_force||5.006000| SvPVutf8x||5.006000| SvPVutf8||5.006000| SvPVx||| SvPV||| SvREFCNT_dec||| SvREFCNT_inc_NN|5.009004||p SvREFCNT_inc_simple_NN|5.009004||p SvREFCNT_inc_simple_void_NN|5.009004||p SvREFCNT_inc_simple_void|5.009004||p SvREFCNT_inc_simple|5.009004||p SvREFCNT_inc_void_NN|5.009004||p SvREFCNT_inc_void|5.009004||p SvREFCNT_inc|||p SvREFCNT||| SvROK_off||| SvROK_on||| SvROK||| SvRV_set|5.009003||p SvRV||| SvRXOK||5.009005| SvRX||5.009005| SvSETMAGIC||| SvSHARED_HASH|5.009003||p SvSHARE||5.007003| SvSTASH_set|5.009003||p SvSTASH||| SvSetMagicSV_nosteal||5.004000| SvSetMagicSV||5.004000| SvSetSV_nosteal||5.004000| SvSetSV||| SvTAINTED_off||5.004000| SvTAINTED_on||5.004000| SvTAINTED||5.004000| SvTAINT||| SvTRUE||| SvTYPE||| SvUNLOCK||5.007003| SvUOK|5.007001|5.006000|p SvUPGRADE||| SvUTF8_off||5.006000| SvUTF8_on||5.006000| SvUTF8||5.006000| SvUVXx|5.004000||p SvUVX|5.004000||p SvUV_nomg|5.009001||p SvUV_set|5.009003||p SvUVx|5.004000||p SvUV|5.004000||p SvVOK||5.008001| SvVSTRING_mg|5.009004||p THIS|||n UNDERBAR|5.009002||p UTF8_MAXBYTES|5.009002||p UVSIZE|5.006000||p UVTYPE|5.006000||p UVXf|5.007001||p UVof|5.006000||p UVuf|5.006000||p UVxf|5.006000||p WARN_ALL|5.006000||p WARN_AMBIGUOUS|5.006000||p WARN_ASSERTIONS|5.011000||p WARN_BAREWORD|5.006000||p WARN_CLOSED|5.006000||p WARN_CLOSURE|5.006000||p WARN_DEBUGGING|5.006000||p WARN_DEPRECATED|5.006000||p WARN_DIGIT|5.006000||p WARN_EXEC|5.006000||p WARN_EXITING|5.006000||p WARN_GLOB|5.006000||p WARN_INPLACE|5.006000||p WARN_INTERNAL|5.006000||p WARN_IO|5.006000||p WARN_LAYER|5.008000||p WARN_MALLOC|5.006000||p WARN_MISC|5.006000||p WARN_NEWLINE|5.006000||p WARN_NUMERIC|5.006000||p WARN_ONCE|5.006000||p WARN_OVERFLOW|5.006000||p WARN_PACK|5.006000||p WARN_PARENTHESIS|5.006000||p WARN_PIPE|5.006000||p WARN_PORTABLE|5.006000||p WARN_PRECEDENCE|5.006000||p WARN_PRINTF|5.006000||p WARN_PROTOTYPE|5.006000||p WARN_QW|5.006000||p WARN_RECURSION|5.006000||p WARN_REDEFINE|5.006000||p WARN_REGEXP|5.006000||p WARN_RESERVED|5.006000||p WARN_SEMICOLON|5.006000||p WARN_SEVERE|5.006000||p WARN_SIGNAL|5.006000||p WARN_SUBSTR|5.006000||p WARN_SYNTAX|5.006000||p WARN_TAINT|5.006000||p WARN_THREADS|5.008000||p WARN_UNINITIALIZED|5.006000||p WARN_UNOPENED|5.006000||p WARN_UNPACK|5.006000||p WARN_UNTIE|5.006000||p WARN_UTF8|5.006000||p WARN_VOID|5.006000||p XCPT_CATCH|5.009002||p XCPT_RETHROW|5.009002||p XCPT_TRY_END|5.009002||p XCPT_TRY_START|5.009002||p XPUSHi||| XPUSHmortal|5.009002||p XPUSHn||| XPUSHp||| XPUSHs||| XPUSHu|5.004000||p XSPROTO|5.010000||p XSRETURN_EMPTY||| XSRETURN_IV||| XSRETURN_NO||| XSRETURN_NV||| XSRETURN_PV||| XSRETURN_UNDEF||| XSRETURN_UV|5.008001||p XSRETURN_YES||| XSRETURN|||p XST_mIV||| XST_mNO||| XST_mNV||| XST_mPV||| XST_mUNDEF||| XST_mUV|5.008001||p XST_mYES||| XS_VERSION_BOOTCHECK||| XS_VERSION||| XSprePUSH|5.006000||p XS||| ZeroD|5.009002||p Zero||| _aMY_CXT|5.007003||p _pMY_CXT|5.007003||p aMY_CXT_|5.007003||p aMY_CXT|5.007003||p aTHXR_|5.011000||p aTHXR|5.011000||p aTHX_|5.006000||p aTHX|5.006000||p add_data|||n addmad||| allocmy||| amagic_call||| amagic_cmp_locale||| amagic_cmp||| amagic_i_ncmp||| amagic_ncmp||| any_dup||| ao||| append_elem||| append_list||| append_madprops||| apply_attrs_my||| apply_attrs_string||5.006001| apply_attrs||| apply||| atfork_lock||5.007003|n atfork_unlock||5.007003|n av_arylen_p||5.009003| av_clear||| av_create_and_push||5.009005| av_create_and_unshift_one||5.009005| av_delete||5.006000| av_exists||5.006000| av_extend||| av_fetch||| av_fill||| av_iter_p||5.011000| av_len||| av_make||| av_pop||| av_push||| av_reify||| av_shift||| av_store||| av_undef||| av_unshift||| ax|||n bad_type||| bind_match||| block_end||| block_gimme||5.004000| block_start||| boolSV|5.004000||p boot_core_PerlIO||| boot_core_UNIVERSAL||| boot_core_mro||| bytes_from_utf8||5.007001| bytes_to_uni|||n bytes_to_utf8||5.006001| call_argv|5.006000||p call_atexit||5.006000| call_list||5.004000| call_method|5.006000||p call_pv|5.006000||p call_sv|5.006000||p calloc||5.007002|n cando||| cast_i32||5.006000| cast_iv||5.006000| cast_ulong||5.006000| cast_uv||5.006000| check_type_and_open||| check_uni||| checkcomma||| checkposixcc||| ckWARN|5.006000||p ck_anoncode||| ck_bitop||| ck_concat||| ck_defined||| ck_delete||| ck_die||| ck_each||| ck_eof||| ck_eval||| ck_exec||| ck_exists||| ck_exit||| ck_ftst||| ck_fun||| ck_glob||| ck_grep||| ck_index||| ck_join||| ck_lfun||| ck_listiob||| ck_match||| ck_method||| ck_null||| ck_open||| ck_readline||| ck_repeat||| ck_require||| ck_return||| ck_rfun||| ck_rvconst||| ck_sassign||| ck_select||| ck_shift||| ck_sort||| ck_spair||| ck_split||| ck_subr||| ck_substr||| ck_svconst||| ck_trunc||| ck_unpack||| ckwarn_d||5.009003| ckwarn||5.009003| cl_and|||n cl_anything|||n cl_init_zero|||n cl_init|||n cl_is_anything|||n cl_or|||n clear_placeholders||| closest_cop||| convert||| cop_free||| cr_textfilter||| create_eval_scope||| croak_nocontext|||vn croak_xs_usage||5.011000| croak|||v csighandler||5.009003|n curmad||| custom_op_desc||5.007003| custom_op_name||5.007003| cv_ckproto_len||| cv_clone||| cv_const_sv||5.004000| cv_dump||| cv_undef||| cx_dump||5.005000| cx_dup||| cxinc||| dAXMARK|5.009003||p dAX|5.007002||p dITEMS|5.007002||p dMARK||| dMULTICALL||5.009003| dMY_CXT_SV|5.007003||p dMY_CXT|5.007003||p dNOOP|5.006000||p dORIGMARK||| dSP||| dTHR|5.004050||p dTHXR|5.011000||p dTHXa|5.006000||p dTHXoa|5.006000||p dTHX|5.006000||p dUNDERBAR|5.009002||p dVAR|5.009003||p dXCPT|5.009002||p dXSARGS||| dXSI32||| dXSTARG|5.006000||p deb_curcv||| deb_nocontext|||vn deb_stack_all||| deb_stack_n||| debop||5.005000| debprofdump||5.005000| debprof||| debstackptrs||5.007003| debstack||5.007003| debug_start_match||| deb||5.007003|v del_sv||| delete_eval_scope||| delimcpy||5.004000| deprecate_old||| deprecate||| despatch_signals||5.007001| destroy_matcher||| die_nocontext|||vn die_where||| die|||v dirp_dup||| div128||| djSP||| do_aexec5||| do_aexec||| do_aspawn||| do_binmode||5.004050| do_chomp||| do_chop||| do_close||| do_dump_pad||| do_eof||| do_exec3||| do_execfree||| do_exec||| do_gv_dump||5.006000| do_gvgv_dump||5.006000| do_hv_dump||5.006000| do_ipcctl||| do_ipcget||| do_join||| do_kv||| do_magic_dump||5.006000| do_msgrcv||| do_msgsnd||| do_oddball||| do_op_dump||5.006000| do_op_xmldump||| do_open9||5.006000| do_openn||5.007001| do_open||5.004000| do_pmop_dump||5.006000| do_pmop_xmldump||| do_print||| do_readline||| do_seek||| do_semop||| do_shmio||| do_smartmatch||| do_spawn_nowait||| do_spawn||| do_sprintf||| do_sv_dump||5.006000| do_sysseek||| do_tell||| do_trans_complex_utf8||| do_trans_complex||| do_trans_count_utf8||| do_trans_count||| do_trans_simple_utf8||| do_trans_simple||| do_trans||| do_vecget||| do_vecset||| do_vop||| docatch||| doeval||| dofile||| dofindlabel||| doform||| doing_taint||5.008001|n dooneliner||| doopen_pm||| doparseform||| dopoptoeval||| dopoptogiven||| dopoptolabel||| dopoptoloop||| dopoptosub_at||| dopoptowhen||| doref||5.009003| dounwind||| dowantarray||| dump_all||5.006000| dump_eval||5.006000| dump_exec_pos||| dump_fds||| dump_form||5.006000| dump_indent||5.006000|v dump_mstats||| dump_packsubs||5.006000| dump_sub||5.006000| dump_sv_child||| dump_trie_interim_list||| dump_trie_interim_table||| dump_trie||| dump_vindent||5.006000| dumpuntil||| dup_attrlist||| emulate_cop_io||| eval_pv|5.006000||p eval_sv|5.006000||p exec_failed||| expect_number||| fbm_compile||5.005000| fbm_instr||5.005000| feature_is_enabled||| fetch_cop_label||5.011000| filter_add||| filter_del||| filter_gets||| filter_read||| find_and_forget_pmops||| find_array_subscript||| find_beginning||| find_byclass||| find_hash_subscript||| find_in_my_stash||| find_runcv||5.008001| find_rundefsvoffset||5.009002| find_script||| find_uninit_var||| first_symbol|||n fold_constants||| forbid_setid||| force_ident||| force_list||| force_next||| force_version||| force_word||| forget_pmop||| form_nocontext|||vn form||5.004000|v fp_dup||| fprintf_nocontext|||vn free_global_struct||| free_tied_hv_pool||| free_tmps||| gen_constant_list||| get_arena||| get_aux_mg||| get_av|5.006000||p get_context||5.006000|n get_cvn_flags||5.009005| get_cv|5.006000||p get_db_sub||| get_debug_opts||| get_hash_seed||| get_hv|5.006000||p get_isa_hash||| get_mstats||| get_no_modify||| get_num||| get_op_descs||5.005000| get_op_names||5.005000| get_opargs||| get_ppaddr||5.006000| get_re_arg||| get_sv|5.006000||p get_vtbl||5.005030| getcwd_sv||5.007002| getenv_len||| glob_2number||| glob_assign_glob||| glob_assign_ref||| gp_dup||| gp_free||| gp_ref||| grok_bin|5.007003||p grok_hex|5.007003||p grok_number|5.007002||p grok_numeric_radix|5.007002||p grok_oct|5.007003||p group_end||| gv_AVadd||| gv_HVadd||| gv_IOadd||| gv_SVadd||| gv_autoload4||5.004000| gv_check||| gv_const_sv||5.009003| gv_dump||5.006000| gv_efullname3||5.004000| gv_efullname4||5.006001| gv_efullname||| gv_ename||| gv_fetchfile_flags||5.009005| gv_fetchfile||| gv_fetchmeth_autoload||5.007003| gv_fetchmethod_autoload||5.004000| gv_fetchmethod_flags||5.011000| gv_fetchmethod||| gv_fetchmeth||| gv_fetchpvn_flags|5.009002||p gv_fetchpvs|5.009004||p gv_fetchpv||| gv_fetchsv||5.009002| gv_fullname3||5.004000| gv_fullname4||5.006001| gv_fullname||| gv_get_super_pkg||| gv_handler||5.007001| gv_init_sv||| gv_init||| gv_name_set||5.009004| gv_stashpvn|5.004000||p gv_stashpvs|5.009003||p gv_stashpv||| gv_stashsv||| he_dup||| hek_dup||| hfreeentries||| hsplit||| hv_assert||5.011000| hv_auxinit|||n hv_backreferences_p||| hv_clear_placeholders||5.009001| hv_clear||| hv_common_key_len||5.010000| hv_common||5.010000| hv_copy_hints_hv||| hv_delayfree_ent||5.004000| hv_delete_common||| hv_delete_ent||5.004000| hv_delete||| hv_eiter_p||5.009003| hv_eiter_set||5.009003| hv_exists_ent||5.004000| hv_exists||| hv_fetch_ent||5.004000| hv_fetchs|5.009003||p hv_fetch||| hv_free_ent||5.004000| hv_iterinit||| hv_iterkeysv||5.004000| hv_iterkey||| hv_iternext_flags||5.008000| hv_iternextsv||| hv_iternext||| hv_iterval||| hv_kill_backrefs||| hv_ksplit||5.004000| hv_magic_check|||n hv_magic||| hv_name_set||5.009003| hv_notallowed||| hv_placeholders_get||5.009003| hv_placeholders_p||5.009003| hv_placeholders_set||5.009003| hv_riter_p||5.009003| hv_riter_set||5.009003| hv_scalar||5.009001| hv_store_ent||5.004000| hv_store_flags||5.008000| hv_stores|5.009004||p hv_store||| hv_undef||| ibcmp_locale||5.004000| ibcmp_utf8||5.007003| ibcmp||| incline||| incpush_if_exists||| incpush_use_sep||| incpush||| ingroup||| init_argv_symbols||| init_debugger||| init_global_struct||| init_i18nl10n||5.006000| init_i18nl14n||5.006000| init_ids||| init_interp||| init_main_stash||| init_perllib||| init_postdump_symbols||| init_predump_symbols||| init_stacks||5.005000| init_tm||5.007002| instr||| intro_my||| intuit_method||| intuit_more||| invert||| io_close||| isALNUMC|5.006000||p isALNUM||| isALPHA||| isASCII|5.006000||p isBLANK|5.006001||p isCNTRL|5.006000||p isDIGIT||| isGRAPH|5.006000||p isGV_with_GP|5.009004||p isLOWER||| isPRINT|5.004000||p isPSXSPC|5.006001||p isPUNCT|5.006000||p isSPACE||| isUPPER||| isXDIGIT|5.006000||p is_an_int||| is_gv_magical_sv||| is_handle_constructor|||n is_list_assignment||| is_lvalue_sub||5.007001| is_uni_alnum_lc||5.006000| is_uni_alnumc_lc||5.006000| is_uni_alnumc||5.006000| is_uni_alnum||5.006000| is_uni_alpha_lc||5.006000| is_uni_alpha||5.006000| is_uni_ascii_lc||5.006000| is_uni_ascii||5.006000| is_uni_cntrl_lc||5.006000| is_uni_cntrl||5.006000| is_uni_digit_lc||5.006000| is_uni_digit||5.006000| is_uni_graph_lc||5.006000| is_uni_graph||5.006000| is_uni_idfirst_lc||5.006000| is_uni_idfirst||5.006000| is_uni_lower_lc||5.006000| is_uni_lower||5.006000| is_uni_print_lc||5.006000| is_uni_print||5.006000| is_uni_punct_lc||5.006000| is_uni_punct||5.006000| is_uni_space_lc||5.006000| is_uni_space||5.006000| is_uni_upper_lc||5.006000| is_uni_upper||5.006000| is_uni_xdigit_lc||5.006000| is_uni_xdigit||5.006000| is_utf8_alnumc||5.006000| is_utf8_alnum||5.006000| is_utf8_alpha||5.006000| is_utf8_ascii||5.006000| is_utf8_char_slow|||n is_utf8_char||5.006000| is_utf8_cntrl||5.006000| is_utf8_common||| is_utf8_digit||5.006000| is_utf8_graph||5.006000| is_utf8_idcont||5.008000| is_utf8_idfirst||5.006000| is_utf8_lower||5.006000| is_utf8_mark||5.006000| is_utf8_print||5.006000| is_utf8_punct||5.006000| is_utf8_space||5.006000| is_utf8_string_loclen||5.009003| is_utf8_string_loc||5.008001| is_utf8_string||5.006001| is_utf8_upper||5.006000| is_utf8_xdigit||5.006000| isa_lookup||| items|||n ix|||n jmaybe||| join_exact||| keyword||| leave_scope||| lex_end||| lex_start||| linklist||| listkids||| list||| load_module_nocontext|||vn load_module|5.006000||pv localize||| looks_like_bool||| looks_like_number||| lop||| mPUSHi|5.009002||p mPUSHn|5.009002||p mPUSHp|5.009002||p mPUSHs|5.011000||p mPUSHu|5.009002||p mXPUSHi|5.009002||p mXPUSHn|5.009002||p mXPUSHp|5.009002||p mXPUSHs|5.011000||p mXPUSHu|5.009002||p mad_free||| madlex||| madparse||| magic_clear_all_env||| magic_clearenv||| magic_clearhint||| magic_clearisa||| magic_clearpack||| magic_clearsig||| magic_dump||5.006000| magic_existspack||| magic_freearylen_p||| magic_freeovrld||| magic_getarylen||| magic_getdefelem||| magic_getnkeys||| magic_getpack||| magic_getpos||| magic_getsig||| magic_getsubstr||| magic_gettaint||| magic_getuvar||| magic_getvec||| magic_get||| magic_killbackrefs||| magic_len||| magic_methcall||| magic_methpack||| magic_nextpack||| magic_regdata_cnt||| magic_regdatum_get||| magic_regdatum_set||| magic_scalarpack||| magic_set_all_env||| magic_setamagic||| magic_setarylen||| magic_setcollxfrm||| magic_setdbline||| magic_setdefelem||| magic_setenv||| magic_sethint||| magic_setisa||| magic_setmglob||| magic_setnkeys||| magic_setpack||| magic_setpos||| magic_setregexp||| magic_setsig||| magic_setsubstr||| magic_settaint||| magic_setutf8||| magic_setuvar||| magic_setvec||| magic_set||| magic_sizepack||| magic_wipepack||| make_matcher||| make_trie_failtable||| make_trie||| malloc_good_size|||n malloced_size|||n malloc||5.007002|n markstack_grow||| matcher_matches_sv||| measure_struct||| memEQ|5.004000||p memNE|5.004000||p mem_collxfrm||| mem_log_common|||n mess_alloc||| mess_nocontext|||vn mess||5.006000|v method_common||| mfree||5.007002|n mg_clear||| mg_copy||| mg_dup||| mg_find||| mg_free||| mg_get||| mg_length||5.005000| mg_localize||| mg_magical||| mg_set||| mg_size||5.005000| mini_mktime||5.007002| missingterm||| mode_from_discipline||| modkids||| mod||| more_bodies||| more_sv||| moreswitches||| mro_get_from_name||5.011000| mro_get_linear_isa_dfs||| mro_get_linear_isa||5.009005| mro_get_private_data||5.011000| mro_isa_changed_in||| mro_meta_dup||| mro_meta_init||| mro_method_changed_in||5.009005| mro_register||5.011000| mro_set_mro||5.011000| mro_set_private_data||5.011000| mul128||| mulexp10|||n my_atof2||5.007002| my_atof||5.006000| my_attrs||| my_bcopy|||n my_betoh16|||n my_betoh32|||n my_betoh64|||n my_betohi|||n my_betohl|||n my_betohs|||n my_bzero|||n my_chsize||| my_clearenv||| my_cxt_index||| my_cxt_init||| my_dirfd||5.009005| my_exit_jump||| my_exit||| my_failure_exit||5.004000| my_fflush_all||5.006000| my_fork||5.007003|n my_htobe16|||n my_htobe32|||n my_htobe64|||n my_htobei|||n my_htobel|||n my_htobes|||n my_htole16|||n my_htole32|||n my_htole64|||n my_htolei|||n my_htolel|||n my_htoles|||n my_htonl||| my_kid||| my_letoh16|||n my_letoh32|||n my_letoh64|||n my_letohi|||n my_letohl|||n my_letohs|||n my_lstat||| my_memcmp||5.004000|n my_memset|||n my_ntohl||| my_pclose||5.004000| my_popen_list||5.007001| my_popen||5.004000| my_setenv||| my_snprintf|5.009004||pvn my_socketpair||5.007003|n my_sprintf|5.009003||pvn my_stat||| my_strftime||5.007002| my_strlcat|5.009004||pn my_strlcpy|5.009004||pn my_swabn|||n my_swap||| my_unexec||| my_vsnprintf||5.009004|n need_utf8|||n newANONATTRSUB||5.006000| newANONHASH||| newANONLIST||| newANONSUB||| newASSIGNOP||| newATTRSUB||5.006000| newAVREF||| newAV||| newBINOP||| newCONDOP||| newCONSTSUB|5.004050||p newCVREF||| newDEFSVOP||| newFORM||| newFOROP||| newGIVENOP||5.009003| newGIVWHENOP||| newGP||| newGVOP||| newGVREF||| newGVgen||| newHVREF||| newHVhv||5.005000| newHV||| newIO||| newLISTOP||| newLOGOP||| newLOOPEX||| newLOOPOP||| newMADPROP||| newMADsv||| newMYSUB||| newNULLLIST||| newOP||| newPADOP||| newPMOP||| newPROG||| newPVOP||| newRANGE||| newRV_inc|5.004000||p newRV_noinc|5.004000||p newRV||| newSLICEOP||| newSTATEOP||| newSUB||| newSVOP||| newSVREF||| newSV_type|5.009005||p newSVhek||5.009003| newSViv||| newSVnv||| newSVpvf_nocontext|||vn newSVpvf||5.004000|v newSVpvn_flags|5.011000||p newSVpvn_share|5.007001||p newSVpvn_utf8|5.011000||p newSVpvn|5.004050||p newSVpvs_flags|5.011000||p newSVpvs_share||5.009003| newSVpvs|5.009003||p newSVpv||| newSVrv||| newSVsv||| newSVuv|5.006000||p newSV||| newTOKEN||| newUNOP||| newWHENOP||5.009003| newWHILEOP||5.009003| newXS_flags||5.009004| newXSproto||5.006000| newXS||5.006000| new_collate||5.006000| new_constant||| new_ctype||5.006000| new_he||| new_logop||| new_numeric||5.006000| new_stackinfo||5.005000| new_version||5.009000| new_warnings_bitfield||| next_symbol||| nextargv||| nextchar||| ninstr||| no_bareword_allowed||| no_fh_allowed||| no_op||| not_a_number||| nothreadhook||5.008000| nuke_stacks||| num_overflow|||n offer_nice_chunk||| oopsAV||| oopsHV||| op_clear||| op_const_sv||| op_dump||5.006000| op_free||| op_getmad_weak||| op_getmad||| op_null||5.007002| op_refcnt_dec||| op_refcnt_inc||| op_refcnt_lock||5.009002| op_refcnt_unlock||5.009002| op_xmldump||| open_script||| pMY_CXT_|5.007003||p pMY_CXT|5.007003||p pTHX_|5.006000||p pTHX|5.006000||p packWARN|5.007003||p pack_cat||5.007003| pack_rec||| package||| packlist||5.008001| pad_add_anon||| pad_add_name||| pad_alloc||| pad_block_start||| pad_check_dup||| pad_compname_type||| pad_findlex||| pad_findmy||| pad_fixup_inner_anons||| pad_free||| pad_leavemy||| pad_new||| pad_peg|||n pad_push||| pad_reset||| pad_setsv||| pad_sv||5.011000| pad_swipe||| pad_tidy||| pad_undef||| parse_body||| parse_unicode_opts||| parser_dup||| parser_free||| path_is_absolute|||n peep||| pending_Slabs_to_ro||| perl_alloc_using|||n perl_alloc|||n perl_clone_using|||n perl_clone|||n perl_construct|||n perl_destruct||5.007003|n perl_free|||n perl_parse||5.006000|n perl_run|||n pidgone||| pm_description||| pmflag||| pmop_dump||5.006000| pmop_xmldump||| pmruntime||| pmtrans||| pop_scope||| pregcomp||5.009005| pregexec||| pregfree2||5.011000| pregfree||| prepend_elem||| prepend_madprops||| printbuf||| printf_nocontext|||vn process_special_blocks||| ptr_table_clear||5.009005| ptr_table_fetch||5.009005| ptr_table_find|||n ptr_table_free||5.009005| ptr_table_new||5.009005| ptr_table_split||5.009005| ptr_table_store||5.009005| push_scope||| put_byte||| pv_display|5.006000||p pv_escape|5.009004||p pv_pretty|5.009004||p pv_uni_display||5.007003| qerror||| qsortsvu||| re_compile||5.009005| re_croak2||| re_dup_guts||| re_intuit_start||5.009005| re_intuit_string||5.006000| readpipe_override||| realloc||5.007002|n reentrant_free||| reentrant_init||| reentrant_retry|||vn reentrant_size||| ref_array_or_hash||| refcounted_he_chain_2hv||| refcounted_he_fetch||| refcounted_he_free||| refcounted_he_new_common||| refcounted_he_new||| refcounted_he_value||| refkids||| refto||| ref||5.011000| reg_check_named_buff_matched||| reg_named_buff_all||5.009005| reg_named_buff_exists||5.009005| reg_named_buff_fetch||5.009005| reg_named_buff_firstkey||5.009005| reg_named_buff_iter||| reg_named_buff_nextkey||5.009005| reg_named_buff_scalar||5.009005| reg_named_buff||| reg_namedseq||| reg_node||| reg_numbered_buff_fetch||| reg_numbered_buff_length||| reg_numbered_buff_store||| reg_qr_package||| reg_recode||| reg_scan_name||| reg_skipcomment||| reg_temp_copy||| reganode||| regatom||| regbranch||| regclass_swash||5.009004| regclass||| regcppop||| regcppush||| regcurly|||n regdump_extflags||| regdump||5.005000| regdupe_internal||| regexec_flags||5.005000| regfree_internal||5.009005| reghop3|||n reghop4|||n reghopmaybe3|||n reginclass||| reginitcolors||5.006000| reginsert||| regmatch||| regnext||5.005000| regpiece||| regpposixcc||| regprop||| regrepeat||| regtail_study||| regtail||| regtry||| reguni||| regwhite|||n reg||| repeatcpy||| report_evil_fh||| report_uninit||| require_pv||5.006000| require_tie_mod||| restore_magic||| rninstr||| rsignal_restore||| rsignal_save||| rsignal_state||5.004000| rsignal||5.004000| run_body||| run_user_filter||| runops_debug||5.005000| runops_standard||5.005000| rvpv_dup||| rxres_free||| rxres_restore||| rxres_save||| safesyscalloc||5.006000|n safesysfree||5.006000|n safesysmalloc||5.006000|n safesysrealloc||5.006000|n same_dirent||| save_I16||5.004000| save_I32||| save_I8||5.006000| save_adelete||5.011000| save_aelem||5.004050| save_alloc||5.006000| save_aptr||| save_ary||| save_bool||5.008001| save_clearsv||| save_delete||| save_destructor_x||5.006000| save_destructor||5.006000| save_freeop||| save_freepv||| save_freesv||| save_generic_pvref||5.006001| save_generic_svref||5.005030| save_gp||5.004000| save_hash||| save_hek_flags|||n save_helem_flags||5.011000| save_helem||5.004050| save_hints||| save_hptr||| save_int||| save_item||| save_iv||5.005000| save_lines||| save_list||| save_long||| save_magic||| save_mortalizesv||5.007001| save_nogv||| save_op||| save_padsv_and_mortalize||5.011000| save_pptr||| save_pushi32ptr||| save_pushptri32ptr||| save_pushptrptr||| save_pushptr||5.011000| save_re_context||5.006000| save_scalar_at||| save_scalar||| save_set_svflags||5.009000| save_shared_pvref||5.007003| save_sptr||| save_svref||| save_vptr||5.006000| savepvn||| savepvs||5.009003| savepv||| savesharedpvn||5.009005| savesharedpv||5.007003| savestack_grow_cnt||5.008001| savestack_grow||| savesvpv||5.009002| sawparens||| scalar_mod_type|||n scalarboolean||| scalarkids||| scalarseq||| scalarvoid||| scalar||| scan_bin||5.006000| scan_commit||| scan_const||| scan_formline||| scan_heredoc||| scan_hex||| scan_ident||| scan_inputsymbol||| scan_num||5.007001| scan_oct||| scan_pat||| scan_str||| scan_subst||| scan_trans||| scan_version||5.009001| scan_vstring||5.009005| scan_word||| scope||| screaminstr||5.005000| search_const||| seed||5.008001| sequence_num||| sequence_tail||| sequence||| set_context||5.006000|n set_numeric_local||5.006000| set_numeric_radix||5.006000| set_numeric_standard||5.006000| setdefout||| share_hek_flags||| share_hek||5.004000| si_dup||| sighandler|||n simplify_sort||| skipspace0||| skipspace1||| skipspace2||| skipspace||| softref2xv||| sortcv_stacked||| sortcv_xsub||| sortcv||| sortsv_flags||5.009003| sortsv||5.007003| space_join_names_mortal||| ss_dup||| stack_grow||| start_force||| start_glob||| start_subparse||5.004000| stashpv_hvname_match||5.011000| stdize_locale||| store_cop_label||| strEQ||| strGE||| strGT||| strLE||| strLT||| strNE||| str_to_version||5.006000| strip_return||| strnEQ||| strnNE||| study_chunk||| sub_crush_depth||| sublex_done||| sublex_push||| sublex_start||| sv_2bool||| sv_2cv||| sv_2io||| sv_2iuv_common||| sv_2iuv_non_preserve||| sv_2iv_flags||5.009001| sv_2iv||| sv_2mortal||| sv_2num||| sv_2nv||| sv_2pv_flags|5.007002||p sv_2pv_nolen|5.006000||p sv_2pvbyte_nolen|5.006000||p sv_2pvbyte|5.006000||p sv_2pvutf8_nolen||5.006000| sv_2pvutf8||5.006000| sv_2pv||| sv_2uv_flags||5.009001| sv_2uv|5.004000||p sv_add_arena||| sv_add_backref||| sv_backoff||| sv_bless||| sv_cat_decode||5.008001| sv_catpv_mg|5.004050||p sv_catpvf_mg_nocontext|||pvn sv_catpvf_mg|5.006000|5.004000|pv sv_catpvf_nocontext|||vn sv_catpvf||5.004000|v sv_catpvn_flags||5.007002| sv_catpvn_mg|5.004050||p sv_catpvn_nomg|5.007002||p sv_catpvn||| sv_catpvs|5.009003||p sv_catpv||| sv_catsv_flags||5.007002| sv_catsv_mg|5.004050||p sv_catsv_nomg|5.007002||p sv_catsv||| sv_catxmlpvn||| sv_catxmlsv||| sv_chop||| sv_clean_all||| sv_clean_objs||| sv_clear||| sv_cmp_locale||5.004000| sv_cmp||| sv_collxfrm||| sv_compile_2op||5.008001| sv_copypv||5.007003| sv_dec||| sv_del_backref||| sv_derived_from||5.004000| sv_destroyable||5.010000| sv_does||5.009004| sv_dump||| sv_dup_inc_multiple||| sv_dup||| sv_eq||| sv_exp_grow||| sv_force_normal_flags||5.007001| sv_force_normal||5.006000| sv_free2||| sv_free_arenas||| sv_free||| sv_gets||5.004000| sv_grow||| sv_i_ncmp||| sv_inc||| sv_insert_flags||5.011000| sv_insert||| sv_isa||| sv_isobject||| sv_iv||5.005000| sv_kill_backrefs||| sv_len_utf8||5.006000| sv_len||| sv_magic_portable|5.011000|5.004000|p sv_magicext||5.007003| sv_magic||| sv_mortalcopy||| sv_ncmp||| sv_newmortal||| sv_newref||| sv_nolocking||5.007003| sv_nosharing||5.007003| sv_nounlocking||| sv_nv||5.005000| sv_peek||5.005000| sv_pos_b2u_midway||| sv_pos_b2u||5.006000| sv_pos_u2b_cached||| sv_pos_u2b_forwards|||n sv_pos_u2b_midway|||n sv_pos_u2b||5.006000| sv_pvbyten_force||5.006000| sv_pvbyten||5.006000| sv_pvbyte||5.006000| sv_pvn_force_flags|5.007002||p sv_pvn_force||| sv_pvn_nomg|5.007003|5.005000|p sv_pvn||5.005000| sv_pvutf8n_force||5.006000| sv_pvutf8n||5.006000| sv_pvutf8||5.006000| sv_pv||5.006000| sv_recode_to_utf8||5.007003| sv_reftype||| sv_release_COW||| sv_replace||| sv_report_used||| sv_reset||| sv_rvweaken||5.006000| sv_setiv_mg|5.004050||p sv_setiv||| sv_setnv_mg|5.006000||p sv_setnv||| sv_setpv_mg|5.004050||p sv_setpvf_mg_nocontext|||pvn sv_setpvf_mg|5.006000|5.004000|pv sv_setpvf_nocontext|||vn sv_setpvf||5.004000|v sv_setpviv_mg||5.008001| sv_setpviv||5.008001| sv_setpvn_mg|5.004050||p sv_setpvn||| sv_setpvs|5.009004||p sv_setpv||| sv_setref_iv||| sv_setref_nv||| sv_setref_pvn||| sv_setref_pv||| sv_setref_uv||5.007001| sv_setsv_cow||| sv_setsv_flags||5.007002| sv_setsv_mg|5.004050||p sv_setsv_nomg|5.007002||p sv_setsv||| sv_setuv_mg|5.004050||p sv_setuv|5.004000||p sv_tainted||5.004000| sv_taint||5.004000| sv_true||5.005000| sv_unglob||| sv_uni_display||5.007003| sv_unmagic||| sv_unref_flags||5.007001| sv_unref||| sv_untaint||5.004000| sv_upgrade||| sv_usepvn_flags||5.009004| sv_usepvn_mg|5.004050||p sv_usepvn||| sv_utf8_decode||5.006000| sv_utf8_downgrade||5.006000| sv_utf8_encode||5.006000| sv_utf8_upgrade_flags_grow||5.011000| sv_utf8_upgrade_flags||5.007002| sv_utf8_upgrade_nomg||5.007002| sv_utf8_upgrade||5.007001| sv_uv|5.005000||p sv_vcatpvf_mg|5.006000|5.004000|p sv_vcatpvfn||5.004000| sv_vcatpvf|5.006000|5.004000|p sv_vsetpvf_mg|5.006000|5.004000|p sv_vsetpvfn||5.004000| sv_vsetpvf|5.006000|5.004000|p sv_xmlpeek||| svtype||| swallow_bom||| swap_match_buff||| swash_fetch||5.007002| swash_get||| swash_init||5.006000| sys_init3||5.010000|n sys_init||5.010000|n sys_intern_clear||| sys_intern_dup||| sys_intern_init||| sys_term||5.010000|n taint_env||| taint_proper||| tmps_grow||5.006000| toLOWER||| toUPPER||| to_byte_substr||| to_uni_fold||5.007003| to_uni_lower_lc||5.006000| to_uni_lower||5.007003| to_uni_title_lc||5.006000| to_uni_title||5.007003| to_uni_upper_lc||5.006000| to_uni_upper||5.007003| to_utf8_case||5.007003| to_utf8_fold||5.007003| to_utf8_lower||5.007003| to_utf8_substr||| to_utf8_title||5.007003| to_utf8_upper||5.007003| token_free||| token_getmad||| tokenize_use||| tokeq||| tokereport||| too_few_arguments||| too_many_arguments||| uiv_2buf|||n unlnk||| unpack_rec||| unpack_str||5.007003| unpackstring||5.008001| unshare_hek_or_pvn||| unshare_hek||| unsharepvn||5.004000| unwind_handler_stack||| update_debugger_info||| upg_version||5.009005| usage||| utf16_to_utf8_reversed||5.006001| utf16_to_utf8||5.006001| utf8_distance||5.006000| utf8_hop||5.006000| utf8_length||5.007001| utf8_mg_pos_cache_update||| utf8_to_bytes||5.006001| utf8_to_uvchr||5.007001| utf8_to_uvuni||5.007001| utf8n_to_uvchr||| utf8n_to_uvuni||5.007001| utilize||| uvchr_to_utf8_flags||5.007003| uvchr_to_utf8||| uvuni_to_utf8_flags||5.007003| uvuni_to_utf8||5.007001| validate_suid||| varname||| vcmp||5.009000| vcroak||5.006000| vdeb||5.007003| vdie_common||| vdie_croak_common||| vdie||| vform||5.006000| visit||| vivify_defelem||| vivify_ref||| vload_module|5.006000||p vmess||5.006000| vnewSVpvf|5.006000|5.004000|p vnormal||5.009002| vnumify||5.009000| vstringify||5.009000| vverify||5.009003| vwarner||5.006000| vwarn||5.006000| wait4pid||| warn_nocontext|||vn warner_nocontext|||vn warner|5.006000|5.004000|pv warn|||v watch||| whichsig||| write_no_mem||| write_to_stderr||| xmldump_all||| xmldump_attr||| xmldump_eval||| xmldump_form||| xmldump_indent|||v xmldump_packsubs||| xmldump_sub||| xmldump_vindent||| yyerror||| yylex||| yyparse||| yywarn||| ); if (exists $opt{'list-unsupported'}) { my $f; for $f (sort { lc $a cmp lc $b } keys %API) { next unless $API{$f}{todo}; print "$f ", '.'x(40-length($f)), " ", format_version($API{$f}{todo}), "\n"; } exit 0; } # Scan for possible replacement candidates my(%replace, %need, %hints, %warnings, %depends); my $replace = 0; my($hint, $define, $function); sub find_api { my $code = shift; $code =~ s{ / (?: \*[^*]*\*+(?:[^$ccs][^*]*\*+)* / | /[^\r\n]*) | "[^"\\]*(?:\\.[^"\\]*)*" | '[^'\\]*(?:\\.[^'\\]*)*' }{}egsx; grep { exists $API{$_} } $code =~ /(\w+)/mg; } while () { if ($hint) { my $h = $hint->[0] eq 'Hint' ? \%hints : \%warnings; if (m{^\s*\*\s(.*?)\s*$}) { for (@{$hint->[1]}) { $h->{$_} ||= ''; # suppress warning with older perls $h->{$_} .= "$1\n"; } } else { undef $hint } } $hint = [$1, [split /,?\s+/, $2]] if m{^\s*$rccs\s+(Hint|Warning):\s+(\w+(?:,?\s+\w+)*)\s*$}; if ($define) { if ($define->[1] =~ /\\$/) { $define->[1] .= $_; } else { if (exists $API{$define->[0]} && $define->[1] !~ /^DPPP_\(/) { my @n = find_api($define->[1]); push @{$depends{$define->[0]}}, @n if @n } undef $define; } } $define = [$1, $2] if m{^\s*#\s*define\s+(\w+)(?:\([^)]*\))?\s+(.*)}; if ($function) { if (/^}/) { if (exists $API{$function->[0]}) { my @n = find_api($function->[1]); push @{$depends{$function->[0]}}, @n if @n } undef $function; } else { $function->[1] .= $_; } } $function = [$1, ''] if m{^DPPP_\(my_(\w+)\)}; $replace = $1 if m{^\s*$rccs\s+Replace:\s+(\d+)\s+$rcce\s*$}; $replace{$2} = $1 if $replace and m{^\s*#\s*define\s+(\w+)(?:\([^)]*\))?\s+(\w+)}; $replace{$2} = $1 if m{^\s*#\s*define\s+(\w+)(?:\([^)]*\))?\s+(\w+).*$rccs\s+Replace\s+$rcce}; $replace{$1} = $2 if m{^\s*$rccs\s+Replace (\w+) with (\w+)\s+$rcce\s*$}; if (m{^\s*$rccs\s+(\w+(\s*,\s*\w+)*)\s+depends\s+on\s+(\w+(\s*,\s*\w+)*)\s+$rcce\s*$}) { my @deps = map { s/\s+//g; $_ } split /,/, $3; my $d; for $d (map { s/\s+//g; $_ } split /,/, $1) { push @{$depends{$d}}, @deps; } } $need{$1} = 1 if m{^#if\s+defined\(NEED_(\w+)(?:_GLOBAL)?\)}; } for (values %depends) { my %s; $_ = [sort grep !$s{$_}++, @$_]; } if (exists $opt{'api-info'}) { my $f; my $count = 0; my $match = $opt{'api-info'} =~ m!^/(.*)/$! ? $1 : "^\Q$opt{'api-info'}\E\$"; for $f (sort { lc $a cmp lc $b } keys %API) { next unless $f =~ /$match/; print "\n=== $f ===\n\n"; my $info = 0; if ($API{$f}{base} || $API{$f}{todo}) { my $base = format_version($API{$f}{base} || $API{$f}{todo}); print "Supported at least starting from perl-$base.\n"; $info++; } if ($API{$f}{provided}) { my $todo = $API{$f}{todo} ? format_version($API{$f}{todo}) : "5.003"; print "Support by $ppport provided back to perl-$todo.\n"; print "Support needs to be explicitly requested by NEED_$f.\n" if exists $need{$f}; print "Depends on: ", join(', ', @{$depends{$f}}), ".\n" if exists $depends{$f}; print "\n$hints{$f}" if exists $hints{$f}; print "\nWARNING:\n$warnings{$f}" if exists $warnings{$f}; $info++; } print "No portability information available.\n" unless $info; $count++; } $count or print "Found no API matching '$opt{'api-info'}'."; print "\n"; exit 0; } if (exists $opt{'list-provided'}) { my $f; for $f (sort { lc $a cmp lc $b } keys %API) { next unless $API{$f}{provided}; my @flags; push @flags, 'explicit' if exists $need{$f}; push @flags, 'depend' if exists $depends{$f}; push @flags, 'hint' if exists $hints{$f}; push @flags, 'warning' if exists $warnings{$f}; my $flags = @flags ? ' ['.join(', ', @flags).']' : ''; print "$f$flags\n"; } exit 0; } my @files; my @srcext = qw( .xs .c .h .cc .cpp -c.inc -xs.inc ); my $srcext = join '|', map { quotemeta $_ } @srcext; if (@ARGV) { my %seen; for (@ARGV) { if (-e) { if (-f) { push @files, $_ unless $seen{$_}++; } else { warn "'$_' is not a file.\n" } } else { my @new = grep { -f } glob $_ or warn "'$_' does not exist.\n"; push @files, grep { !$seen{$_}++ } @new; } } } else { eval { require File::Find; File::Find::find(sub { $File::Find::name =~ /($srcext)$/i and push @files, $File::Find::name; }, '.'); }; if ($@) { @files = map { glob "*$_" } @srcext; } } if (!@ARGV || $opt{filter}) { my(@in, @out); my %xsc = map { /(.*)\.xs$/ ? ("$1.c" => 1, "$1.cc" => 1) : () } @files; for (@files) { my $out = exists $xsc{$_} || /\b\Q$ppport\E$/i || !/($srcext)$/i; push @{ $out ? \@out : \@in }, $_; } if (@ARGV && @out) { warning("Skipping the following files (use --nofilter to avoid this):\n| ", join "\n| ", @out); } @files = @in; } die "No input files given!\n" unless @files; my(%files, %global, %revreplace); %revreplace = reverse %replace; my $filename; my $patch_opened = 0; for $filename (@files) { unless (open IN, "<$filename") { warn "Unable to read from $filename: $!\n"; next; } info("Scanning $filename ..."); my $c = do { local $/; }; close IN; my %file = (orig => $c, changes => 0); # Temporarily remove C/XS comments and strings from the code my @ccom; $c =~ s{ ( ^$HS*\#$HS*include\b[^\r\n]+\b(?:\Q$ppport\E|XSUB\.h)\b[^\r\n]* | ^$HS*\#$HS*(?:define|elif|if(?:def)?)\b[^\r\n]* ) | ( ^$HS*\#[^\r\n]* | "[^"\\]*(?:\\.[^"\\]*)*" | '[^'\\]*(?:\\.[^'\\]*)*' | / (?: \*[^*]*\*+(?:[^$ccs][^*]*\*+)* / | /[^\r\n]* ) ) }{ defined $2 and push @ccom, $2; defined $1 ? $1 : "$ccs$#ccom$cce" }mgsex; $file{ccom} = \@ccom; $file{code} = $c; $file{has_inc_ppport} = $c =~ /^$HS*#$HS*include[^\r\n]+\b\Q$ppport\E\b/m; my $func; for $func (keys %API) { my $match = $func; $match .= "|$revreplace{$func}" if exists $revreplace{$func}; if ($c =~ /\b(?:Perl_)?($match)\b/) { $file{uses_replace}{$1}++ if exists $revreplace{$func} && $1 eq $revreplace{$func}; $file{uses_Perl}{$func}++ if $c =~ /\bPerl_$func\b/; if (exists $API{$func}{provided}) { $file{uses_provided}{$func}++; if (!exists $API{$func}{base} || $API{$func}{base} > $opt{'compat-version'}) { $file{uses}{$func}++; my @deps = rec_depend($func); if (@deps) { $file{uses_deps}{$func} = \@deps; for (@deps) { $file{uses}{$_} = 0 unless exists $file{uses}{$_}; } } for ($func, @deps) { $file{needs}{$_} = 'static' if exists $need{$_}; } } } if (exists $API{$func}{todo} && $API{$func}{todo} > $opt{'compat-version'}) { if ($c =~ /\b$func\b/) { $file{uses_todo}{$func}++; } } } } while ($c =~ /^$HS*#$HS*define$HS+(NEED_(\w+?)(_GLOBAL)?)\b/mg) { if (exists $need{$2}) { $file{defined $3 ? 'needed_global' : 'needed_static'}{$2}++; } else { warning("Possibly wrong #define $1 in $filename") } } for (qw(uses needs uses_todo needed_global needed_static)) { for $func (keys %{$file{$_}}) { push @{$global{$_}{$func}}, $filename; } } $files{$filename} = \%file; } # Globally resolve NEED_'s my $need; for $need (keys %{$global{needs}}) { if (@{$global{needs}{$need}} > 1) { my @targets = @{$global{needs}{$need}}; my @t = grep $files{$_}{needed_global}{$need}, @targets; @targets = @t if @t; @t = grep /\.xs$/i, @targets; @targets = @t if @t; my $target = shift @targets; $files{$target}{needs}{$need} = 'global'; for (@{$global{needs}{$need}}) { $files{$_}{needs}{$need} = 'extern' if $_ ne $target; } } } for $filename (@files) { exists $files{$filename} or next; info("=== Analyzing $filename ==="); my %file = %{$files{$filename}}; my $func; my $c = $file{code}; my $warnings = 0; for $func (sort keys %{$file{uses_Perl}}) { if ($API{$func}{varargs}) { unless ($API{$func}{nothxarg}) { my $changes = ($c =~ s{\b(Perl_$func\s*\(\s*)(?!aTHX_?)(\)|[^\s)]*\))} { $1 . ($2 eq ')' ? 'aTHX' : 'aTHX_ ') . $2 }ge); if ($changes) { warning("Doesn't pass interpreter argument aTHX to Perl_$func"); $file{changes} += $changes; } } } else { warning("Uses Perl_$func instead of $func"); $file{changes} += ($c =~ s{\bPerl_$func(\s*)\((\s*aTHX_?)?\s*} {$func$1(}g); } } for $func (sort keys %{$file{uses_replace}}) { warning("Uses $func instead of $replace{$func}"); $file{changes} += ($c =~ s/\b$func\b/$replace{$func}/g); } for $func (sort keys %{$file{uses_provided}}) { if ($file{uses}{$func}) { if (exists $file{uses_deps}{$func}) { diag("Uses $func, which depends on ", join(', ', @{$file{uses_deps}{$func}})); } else { diag("Uses $func"); } } $warnings += hint($func); } unless ($opt{quiet}) { for $func (sort keys %{$file{uses_todo}}) { print "*** WARNING: Uses $func, which may not be portable below perl ", format_version($API{$func}{todo}), ", even with '$ppport'\n"; $warnings++; } } for $func (sort keys %{$file{needed_static}}) { my $message = ''; if (not exists $file{uses}{$func}) { $message = "No need to define NEED_$func if $func is never used"; } elsif (exists $file{needs}{$func} && $file{needs}{$func} ne 'static') { $message = "No need to define NEED_$func when already needed globally"; } if ($message) { diag($message); $file{changes} += ($c =~ s/^$HS*#$HS*define$HS+NEED_$func\b.*$LF//mg); } } for $func (sort keys %{$file{needed_global}}) { my $message = ''; if (not exists $global{uses}{$func}) { $message = "No need to define NEED_${func}_GLOBAL if $func is never used"; } elsif (exists $file{needs}{$func}) { if ($file{needs}{$func} eq 'extern') { $message = "No need to define NEED_${func}_GLOBAL when already needed globally"; } elsif ($file{needs}{$func} eq 'static') { $message = "No need to define NEED_${func}_GLOBAL when only used in this file"; } } if ($message) { diag($message); $file{changes} += ($c =~ s/^$HS*#$HS*define$HS+NEED_${func}_GLOBAL\b.*$LF//mg); } } $file{needs_inc_ppport} = keys %{$file{uses}}; if ($file{needs_inc_ppport}) { my $pp = ''; for $func (sort keys %{$file{needs}}) { my $type = $file{needs}{$func}; next if $type eq 'extern'; my $suffix = $type eq 'global' ? '_GLOBAL' : ''; unless (exists $file{"needed_$type"}{$func}) { if ($type eq 'global') { diag("Files [@{$global{needs}{$func}}] need $func, adding global request"); } else { diag("File needs $func, adding static request"); } $pp .= "#define NEED_$func$suffix\n"; } } if ($pp && ($c =~ s/^(?=$HS*#$HS*define$HS+NEED_\w+)/$pp/m)) { $pp = ''; $file{changes}++; } unless ($file{has_inc_ppport}) { diag("Needs to include '$ppport'"); $pp .= qq(#include "$ppport"\n) } if ($pp) { $file{changes} += ($c =~ s/^($HS*#$HS*define$HS+NEED_\w+.*?)^/$1$pp/ms) || ($c =~ s/^(?=$HS*#$HS*include.*\Q$ppport\E)/$pp/m) || ($c =~ s/^($HS*#$HS*include.*XSUB.*\s*?)^/$1$pp/m) || ($c =~ s/^/$pp/); } } else { if ($file{has_inc_ppport}) { diag("No need to include '$ppport'"); $file{changes} += ($c =~ s/^$HS*?#$HS*include.*\Q$ppport\E.*?$LF//m); } } # put back in our C comments my $ix; my $cppc = 0; my @ccom = @{$file{ccom}}; for $ix (0 .. $#ccom) { if (!$opt{cplusplus} && $ccom[$ix] =~ s!^//!!) { $cppc++; $file{changes} += $c =~ s/$rccs$ix$rcce/$ccs$ccom[$ix] $cce/; } else { $c =~ s/$rccs$ix$rcce/$ccom[$ix]/; } } if ($cppc) { my $s = $cppc != 1 ? 's' : ''; warning("Uses $cppc C++ style comment$s, which is not portable"); } my $s = $warnings != 1 ? 's' : ''; my $warn = $warnings ? " ($warnings warning$s)" : ''; info("Analysis completed$warn"); if ($file{changes}) { if (exists $opt{copy}) { my $newfile = "$filename$opt{copy}"; if (-e $newfile) { error("'$newfile' already exists, refusing to write copy of '$filename'"); } else { local *F; if (open F, ">$newfile") { info("Writing copy of '$filename' with changes to '$newfile'"); print F $c; close F; } else { error("Cannot open '$newfile' for writing: $!"); } } } elsif (exists $opt{patch} || $opt{changes}) { if (exists $opt{patch}) { unless ($patch_opened) { if (open PATCH, ">$opt{patch}") { $patch_opened = 1; } else { error("Cannot open '$opt{patch}' for writing: $!"); delete $opt{patch}; $opt{changes} = 1; goto fallback; } } mydiff(\*PATCH, $filename, $c); } else { fallback: info("Suggested changes:"); mydiff(\*STDOUT, $filename, $c); } } else { my $s = $file{changes} == 1 ? '' : 's'; info("$file{changes} potentially required change$s detected"); } } else { info("Looks good"); } } close PATCH if $patch_opened; exit 0; sub try_use { eval "use @_;"; return $@ eq '' } sub mydiff { local *F = shift; my($file, $str) = @_; my $diff; if (exists $opt{diff}) { $diff = run_diff($opt{diff}, $file, $str); } if (!defined $diff and try_use('Text::Diff')) { $diff = Text::Diff::diff($file, \$str, { STYLE => 'Unified' }); $diff = <
$tmp") { print F $str; close F; if (open F, "$prog $file $tmp |") { while () { s/\Q$tmp\E/$file.patched/; $diff .= $_; } close F; unlink $tmp; return $diff; } unlink $tmp; } else { error("Cannot open '$tmp' for writing: $!"); } return undef; } sub rec_depend { my($func, $seen) = @_; return () unless exists $depends{$func}; $seen = {%{$seen||{}}}; return () if $seen->{$func}++; my %s; grep !$s{$_}++, map { ($_, rec_depend($_, $seen)) } @{$depends{$func}}; } sub parse_version { my $ver = shift; if ($ver =~ /^(\d+)\.(\d+)\.(\d+)$/) { return ($1, $2, $3); } elsif ($ver !~ /^\d+\.[\d_]+$/) { die "cannot parse version '$ver'\n"; } $ver =~ s/_//g; $ver =~ s/$/000000/; my($r,$v,$s) = $ver =~ /(\d+)\.(\d{3})(\d{3})/; $v = int $v; $s = int $s; if ($r < 5 || ($r == 5 && $v < 6)) { if ($s % 10) { die "cannot parse version '$ver'\n"; } } return ($r, $v, $s); } sub format_version { my $ver = shift; $ver =~ s/$/000000/; my($r,$v,$s) = $ver =~ /(\d+)\.(\d{3})(\d{3})/; $v = int $v; $s = int $s; if ($r < 5 || ($r == 5 && $v < 6)) { if ($s % 10) { die "invalid version '$ver'\n"; } $s /= 10; $ver = sprintf "%d.%03d", $r, $v; $s > 0 and $ver .= sprintf "_%02d", $s; return $ver; } return sprintf "%d.%d.%d", $r, $v, $s; } sub info { $opt{quiet} and return; print @_, "\n"; } sub diag { $opt{quiet} and return; $opt{diag} and print @_, "\n"; } sub warning { $opt{quiet} and return; print "*** ", @_, "\n"; } sub error { print "*** ERROR: ", @_, "\n"; } my %given_hints; my %given_warnings; sub hint { $opt{quiet} and return; my $func = shift; my $rv = 0; if (exists $warnings{$func} && !$given_warnings{$func}++) { my $warn = $warnings{$func}; $warn =~ s!^!*** !mg; print "*** WARNING: $func\n", $warn; $rv++; } if ($opt{hints} && exists $hints{$func} && !$given_hints{$func}++) { my $hint = $hints{$func}; $hint =~ s/^/ /mg; print " --- hint for $func ---\n", $hint; } $rv; } sub usage { my($usage) = do { local(@ARGV,$/)=($0); <> } =~ /^=head\d$HS+SYNOPSIS\s*^(.*?)\s*^=/ms; my %M = ( 'I' => '*' ); $usage =~ s/^\s*perl\s+\S+/$^X $0/; $usage =~ s/([A-Z])<([^>]+)>/$M{$1}$2$M{$1}/g; print < }; my($copy) = $self =~ /^=head\d\s+COPYRIGHT\s*^(.*?)^=\w+/ms; $copy =~ s/^(?=\S+)/ /gms; $self =~ s/^$HS+Do NOT edit.*?(?=^-)/$copy/ms; $self =~ s/^SKIP.*(?=^__DATA__)/SKIP if (\@ARGV && \$ARGV[0] eq '--unstrip') { eval { require Devel::PPPort }; \$@ and die "Cannot require Devel::PPPort, please install.\\n"; if (eval \$Devel::PPPort::VERSION < $VERSION) { die "$0 was originally generated with Devel::PPPort $VERSION.\\n" . "Your Devel::PPPort is only version \$Devel::PPPort::VERSION.\\n" . "Please install a newer version, or --unstrip will not work.\\n"; } Devel::PPPort::WriteFile(\$0); exit 0; } print <$0" or die "cannot strip $0: $!\n"; print OUT "$pl$c\n"; exit 0; } __DATA__ */ #ifndef _P_P_PORTABILITY_H_ #define _P_P_PORTABILITY_H_ #ifndef DPPP_NAMESPACE # define DPPP_NAMESPACE DPPP_ #endif #define DPPP_CAT2(x,y) CAT2(x,y) #define DPPP_(name) DPPP_CAT2(DPPP_NAMESPACE, name) #ifndef PERL_REVISION # if !defined(__PATCHLEVEL_H_INCLUDED__) && !(defined(PATCHLEVEL) && defined(SUBVERSION)) # define PERL_PATCHLEVEL_H_IMPLICIT # include # endif # if !(defined(PERL_VERSION) || (defined(SUBVERSION) && defined(PATCHLEVEL))) # include # endif # ifndef PERL_REVISION # define PERL_REVISION (5) /* Replace: 1 */ # define PERL_VERSION PATCHLEVEL # define PERL_SUBVERSION SUBVERSION /* Replace PERL_PATCHLEVEL with PERL_VERSION */ /* Replace: 0 */ # endif #endif #define _dpppDEC2BCD(dec) ((((dec)/100)<<8)|((((dec)%100)/10)<<4)|((dec)%10)) #define PERL_BCDVERSION ((_dpppDEC2BCD(PERL_REVISION)<<24)|(_dpppDEC2BCD(PERL_VERSION)<<12)|_dpppDEC2BCD(PERL_SUBVERSION)) /* It is very unlikely that anyone will try to use this with Perl 6 (or greater), but who knows. */ #if PERL_REVISION != 5 # error ppport.h only works with Perl version 5 #endif /* PERL_REVISION != 5 */ #ifndef dTHR # define dTHR dNOOP #endif #ifndef dTHX # define dTHX dNOOP #endif #ifndef dTHXa # define dTHXa(x) dNOOP #endif #ifndef pTHX # define pTHX void #endif #ifndef pTHX_ # define pTHX_ #endif #ifndef aTHX # define aTHX #endif #ifndef aTHX_ # define aTHX_ #endif #if (PERL_BCDVERSION < 0x5006000) # ifdef USE_THREADS # define aTHXR thr # define aTHXR_ thr, # else # define aTHXR # define aTHXR_ # endif # define dTHXR dTHR #else # define aTHXR aTHX # define aTHXR_ aTHX_ # define dTHXR dTHX #endif #ifndef dTHXoa # define dTHXoa(x) dTHXa(x) #endif #ifdef I_LIMITS # include #endif #ifndef PERL_UCHAR_MIN # define PERL_UCHAR_MIN ((unsigned char)0) #endif #ifndef PERL_UCHAR_MAX # ifdef UCHAR_MAX # define PERL_UCHAR_MAX ((unsigned char)UCHAR_MAX) # else # ifdef MAXUCHAR # define PERL_UCHAR_MAX ((unsigned char)MAXUCHAR) # else # define PERL_UCHAR_MAX ((unsigned char)~(unsigned)0) # endif # endif #endif #ifndef PERL_USHORT_MIN # define PERL_USHORT_MIN ((unsigned short)0) #endif #ifndef PERL_USHORT_MAX # ifdef USHORT_MAX # define PERL_USHORT_MAX ((unsigned short)USHORT_MAX) # else # ifdef MAXUSHORT # define PERL_USHORT_MAX ((unsigned short)MAXUSHORT) # else # ifdef USHRT_MAX # define PERL_USHORT_MAX ((unsigned short)USHRT_MAX) # else # define PERL_USHORT_MAX ((unsigned short)~(unsigned)0) # endif # endif # endif #endif #ifndef PERL_SHORT_MAX # ifdef SHORT_MAX # define PERL_SHORT_MAX ((short)SHORT_MAX) # else # ifdef MAXSHORT /* Often used in */ # define PERL_SHORT_MAX ((short)MAXSHORT) # else # ifdef SHRT_MAX # define PERL_SHORT_MAX ((short)SHRT_MAX) # else # define PERL_SHORT_MAX ((short) (PERL_USHORT_MAX >> 1)) # endif # endif # endif #endif #ifndef PERL_SHORT_MIN # ifdef SHORT_MIN # define PERL_SHORT_MIN ((short)SHORT_MIN) # else # ifdef MINSHORT # define PERL_SHORT_MIN ((short)MINSHORT) # else # ifdef SHRT_MIN # define PERL_SHORT_MIN ((short)SHRT_MIN) # else # define PERL_SHORT_MIN (-PERL_SHORT_MAX - ((3 & -1) == 3)) # endif # endif # endif #endif #ifndef PERL_UINT_MAX # ifdef UINT_MAX # define PERL_UINT_MAX ((unsigned int)UINT_MAX) # else # ifdef MAXUINT # define PERL_UINT_MAX ((unsigned int)MAXUINT) # else # define PERL_UINT_MAX (~(unsigned int)0) # endif # endif #endif #ifndef PERL_UINT_MIN # define PERL_UINT_MIN ((unsigned int)0) #endif #ifndef PERL_INT_MAX # ifdef INT_MAX # define PERL_INT_MAX ((int)INT_MAX) # else # ifdef MAXINT /* Often used in */ # define PERL_INT_MAX ((int)MAXINT) # else # define PERL_INT_MAX ((int)(PERL_UINT_MAX >> 1)) # endif # endif #endif #ifndef PERL_INT_MIN # ifdef INT_MIN # define PERL_INT_MIN ((int)INT_MIN) # else # ifdef MININT # define PERL_INT_MIN ((int)MININT) # else # define PERL_INT_MIN (-PERL_INT_MAX - ((3 & -1) == 3)) # endif # endif #endif #ifndef PERL_ULONG_MAX # ifdef ULONG_MAX # define PERL_ULONG_MAX ((unsigned long)ULONG_MAX) # else # ifdef MAXULONG # define PERL_ULONG_MAX ((unsigned long)MAXULONG) # else # define PERL_ULONG_MAX (~(unsigned long)0) # endif # endif #endif #ifndef PERL_ULONG_MIN # define PERL_ULONG_MIN ((unsigned long)0L) #endif #ifndef PERL_LONG_MAX # ifdef LONG_MAX # define PERL_LONG_MAX ((long)LONG_MAX) # else # ifdef MAXLONG # define PERL_LONG_MAX ((long)MAXLONG) # else # define PERL_LONG_MAX ((long) (PERL_ULONG_MAX >> 1)) # endif # endif #endif #ifndef PERL_LONG_MIN # ifdef LONG_MIN # define PERL_LONG_MIN ((long)LONG_MIN) # else # ifdef MINLONG # define PERL_LONG_MIN ((long)MINLONG) # else # define PERL_LONG_MIN (-PERL_LONG_MAX - ((3 & -1) == 3)) # endif # endif #endif #if defined(HAS_QUAD) && (defined(convex) || defined(uts)) # ifndef PERL_UQUAD_MAX # ifdef ULONGLONG_MAX # define PERL_UQUAD_MAX ((unsigned long long)ULONGLONG_MAX) # else # ifdef MAXULONGLONG # define PERL_UQUAD_MAX ((unsigned long long)MAXULONGLONG) # else # define PERL_UQUAD_MAX (~(unsigned long long)0) # endif # endif # endif # ifndef PERL_UQUAD_MIN # define PERL_UQUAD_MIN ((unsigned long long)0L) # endif # ifndef PERL_QUAD_MAX # ifdef LONGLONG_MAX # define PERL_QUAD_MAX ((long long)LONGLONG_MAX) # else # ifdef MAXLONGLONG # define PERL_QUAD_MAX ((long long)MAXLONGLONG) # else # define PERL_QUAD_MAX ((long long) (PERL_UQUAD_MAX >> 1)) # endif # endif # endif # ifndef PERL_QUAD_MIN # ifdef LONGLONG_MIN # define PERL_QUAD_MIN ((long long)LONGLONG_MIN) # else # ifdef MINLONGLONG # define PERL_QUAD_MIN ((long long)MINLONGLONG) # else # define PERL_QUAD_MIN (-PERL_QUAD_MAX - ((3 & -1) == 3)) # endif # endif # endif #endif /* This is based on code from 5.003 perl.h */ #ifdef HAS_QUAD # ifdef cray #ifndef IVTYPE # define IVTYPE int #endif #ifndef IV_MIN # define IV_MIN PERL_INT_MIN #endif #ifndef IV_MAX # define IV_MAX PERL_INT_MAX #endif #ifndef UV_MIN # define UV_MIN PERL_UINT_MIN #endif #ifndef UV_MAX # define UV_MAX PERL_UINT_MAX #endif # ifdef INTSIZE #ifndef IVSIZE # define IVSIZE INTSIZE #endif # endif # else # if defined(convex) || defined(uts) #ifndef IVTYPE # define IVTYPE long long #endif #ifndef IV_MIN # define IV_MIN PERL_QUAD_MIN #endif #ifndef IV_MAX # define IV_MAX PERL_QUAD_MAX #endif #ifndef UV_MIN # define UV_MIN PERL_UQUAD_MIN #endif #ifndef UV_MAX # define UV_MAX PERL_UQUAD_MAX #endif # ifdef LONGLONGSIZE #ifndef IVSIZE # define IVSIZE LONGLONGSIZE #endif # endif # else #ifndef IVTYPE # define IVTYPE long #endif #ifndef IV_MIN # define IV_MIN PERL_LONG_MIN #endif #ifndef IV_MAX # define IV_MAX PERL_LONG_MAX #endif #ifndef UV_MIN # define UV_MIN PERL_ULONG_MIN #endif #ifndef UV_MAX # define UV_MAX PERL_ULONG_MAX #endif # ifdef LONGSIZE #ifndef IVSIZE # define IVSIZE LONGSIZE #endif # endif # endif # endif #ifndef IVSIZE # define IVSIZE 8 #endif #ifndef PERL_QUAD_MIN # define PERL_QUAD_MIN IV_MIN #endif #ifndef PERL_QUAD_MAX # define PERL_QUAD_MAX IV_MAX #endif #ifndef PERL_UQUAD_MIN # define PERL_UQUAD_MIN UV_MIN #endif #ifndef PERL_UQUAD_MAX # define PERL_UQUAD_MAX UV_MAX #endif #else #ifndef IVTYPE # define IVTYPE long #endif #ifndef IV_MIN # define IV_MIN PERL_LONG_MIN #endif #ifndef IV_MAX # define IV_MAX PERL_LONG_MAX #endif #ifndef UV_MIN # define UV_MIN PERL_ULONG_MIN #endif #ifndef UV_MAX # define UV_MAX PERL_ULONG_MAX #endif #endif #ifndef IVSIZE # ifdef LONGSIZE # define IVSIZE LONGSIZE # else # define IVSIZE 4 /* A bold guess, but the best we can make. */ # endif #endif #ifndef UVTYPE # define UVTYPE unsigned IVTYPE #endif #ifndef UVSIZE # define UVSIZE IVSIZE #endif #ifndef sv_setuv # define sv_setuv(sv, uv) \ STMT_START { \ UV TeMpUv = uv; \ if (TeMpUv <= IV_MAX) \ sv_setiv(sv, TeMpUv); \ else \ sv_setnv(sv, (double)TeMpUv); \ } STMT_END #endif #ifndef newSVuv # define newSVuv(uv) ((uv) <= IV_MAX ? newSViv((IV)uv) : newSVnv((NV)uv)) #endif #ifndef sv_2uv # define sv_2uv(sv) ((PL_Sv = (sv)), (UV) (SvNOK(PL_Sv) ? SvNV(PL_Sv) : sv_2nv(PL_Sv))) #endif #ifndef SvUVX # define SvUVX(sv) ((UV)SvIVX(sv)) #endif #ifndef SvUVXx # define SvUVXx(sv) SvUVX(sv) #endif #ifndef SvUV # define SvUV(sv) (SvIOK(sv) ? SvUVX(sv) : sv_2uv(sv)) #endif #ifndef SvUVx # define SvUVx(sv) ((PL_Sv = (sv)), SvUV(PL_Sv)) #endif /* Hint: sv_uv * Always use the SvUVx() macro instead of sv_uv(). */ #ifndef sv_uv # define sv_uv(sv) SvUVx(sv) #endif #if !defined(SvUOK) && defined(SvIOK_UV) # define SvUOK(sv) SvIOK_UV(sv) #endif #ifndef XST_mUV # define XST_mUV(i,v) (ST(i) = sv_2mortal(newSVuv(v)) ) #endif #ifndef XSRETURN_UV # define XSRETURN_UV(v) STMT_START { XST_mUV(0,v); XSRETURN(1); } STMT_END #endif #ifndef PUSHu # define PUSHu(u) STMT_START { sv_setuv(TARG, (UV)(u)); PUSHTARG; } STMT_END #endif #ifndef XPUSHu # define XPUSHu(u) STMT_START { sv_setuv(TARG, (UV)(u)); XPUSHTARG; } STMT_END #endif #ifdef HAS_MEMCMP #ifndef memNE # define memNE(s1,s2,l) (memcmp(s1,s2,l)) #endif #ifndef memEQ # define memEQ(s1,s2,l) (!memcmp(s1,s2,l)) #endif #else #ifndef memNE # define memNE(s1,s2,l) (bcmp(s1,s2,l)) #endif #ifndef memEQ # define memEQ(s1,s2,l) (!bcmp(s1,s2,l)) #endif #endif #ifndef MoveD # define MoveD(s,d,n,t) memmove((char*)(d),(char*)(s), (n) * sizeof(t)) #endif #ifndef CopyD # define CopyD(s,d,n,t) memcpy((char*)(d),(char*)(s), (n) * sizeof(t)) #endif #ifdef HAS_MEMSET #ifndef ZeroD # define ZeroD(d,n,t) memzero((char*)(d), (n) * sizeof(t)) #endif #else #ifndef ZeroD # define ZeroD(d,n,t) ((void)memzero((char*)(d), (n) * sizeof(t)), d) #endif #endif #ifndef PoisonWith # define PoisonWith(d,n,t,b) (void)memset((char*)(d), (U8)(b), (n) * sizeof(t)) #endif #ifndef PoisonNew # define PoisonNew(d,n,t) PoisonWith(d,n,t,0xAB) #endif #ifndef PoisonFree # define PoisonFree(d,n,t) PoisonWith(d,n,t,0xEF) #endif #ifndef Poison # define Poison(d,n,t) PoisonFree(d,n,t) #endif #ifndef Newx # define Newx(v,n,t) New(0,v,n,t) #endif #ifndef Newxc # define Newxc(v,n,t,c) Newc(0,v,n,t,c) #endif #ifndef Newxz # define Newxz(v,n,t) Newz(0,v,n,t) #endif #ifndef PERL_UNUSED_DECL # ifdef HASATTRIBUTE # if (defined(__GNUC__) && defined(__cplusplus)) || defined(__INTEL_COMPILER) # define PERL_UNUSED_DECL # else # define PERL_UNUSED_DECL __attribute__((unused)) # endif # else # define PERL_UNUSED_DECL # endif #endif #ifndef PERL_UNUSED_ARG # if defined(lint) && defined(S_SPLINT_S) /* www.splint.org */ # include # define PERL_UNUSED_ARG(x) NOTE(ARGUNUSED(x)) # else # define PERL_UNUSED_ARG(x) ((void)x) # endif #endif #ifndef PERL_UNUSED_VAR # define PERL_UNUSED_VAR(x) ((void)x) #endif #ifndef PERL_UNUSED_CONTEXT # ifdef USE_ITHREADS # define PERL_UNUSED_CONTEXT PERL_UNUSED_ARG(my_perl) # else # define PERL_UNUSED_CONTEXT # endif #endif #ifndef NOOP # define NOOP /*EMPTY*/(void)0 #endif #ifndef dNOOP # define dNOOP extern int /*@unused@*/ Perl___notused PERL_UNUSED_DECL #endif #ifndef NVTYPE # if defined(USE_LONG_DOUBLE) && defined(HAS_LONG_DOUBLE) # define NVTYPE long double # else # define NVTYPE double # endif typedef NVTYPE NV; #endif #ifndef INT2PTR # if (IVSIZE == PTRSIZE) && (UVSIZE == PTRSIZE) # define PTRV UV # define INT2PTR(any,d) (any)(d) # else # if PTRSIZE == LONGSIZE # define PTRV unsigned long # else # define PTRV unsigned # endif # define INT2PTR(any,d) (any)(PTRV)(d) # endif #endif #ifndef PTR2ul # if PTRSIZE == LONGSIZE # define PTR2ul(p) (unsigned long)(p) # else # define PTR2ul(p) INT2PTR(unsigned long,p) # endif #endif #ifndef PTR2nat # define PTR2nat(p) (PTRV)(p) #endif #ifndef NUM2PTR # define NUM2PTR(any,d) (any)PTR2nat(d) #endif #ifndef PTR2IV # define PTR2IV(p) INT2PTR(IV,p) #endif #ifndef PTR2UV # define PTR2UV(p) INT2PTR(UV,p) #endif #ifndef PTR2NV # define PTR2NV(p) NUM2PTR(NV,p) #endif #undef START_EXTERN_C #undef END_EXTERN_C #undef EXTERN_C #ifdef __cplusplus # define START_EXTERN_C extern "C" { # define END_EXTERN_C } # define EXTERN_C extern "C" #else # define START_EXTERN_C # define END_EXTERN_C # define EXTERN_C extern #endif #if defined(PERL_GCC_PEDANTIC) # ifndef PERL_GCC_BRACE_GROUPS_FORBIDDEN # define PERL_GCC_BRACE_GROUPS_FORBIDDEN # endif #endif #if defined(__GNUC__) && !defined(PERL_GCC_BRACE_GROUPS_FORBIDDEN) && !defined(__cplusplus) # ifndef PERL_USE_GCC_BRACE_GROUPS # define PERL_USE_GCC_BRACE_GROUPS # endif #endif #undef STMT_START #undef STMT_END #ifdef PERL_USE_GCC_BRACE_GROUPS # define STMT_START (void)( /* gcc supports ``({ STATEMENTS; })'' */ # define STMT_END ) #else # if defined(VOIDFLAGS) && (VOIDFLAGS) && (defined(sun) || defined(__sun__)) && !defined(__GNUC__) # define STMT_START if (1) # define STMT_END else (void)0 # else # define STMT_START do # define STMT_END while (0) # endif #endif #ifndef boolSV # define boolSV(b) ((b) ? &PL_sv_yes : &PL_sv_no) #endif /* DEFSV appears first in 5.004_56 */ #ifndef DEFSV # define DEFSV GvSV(PL_defgv) #endif #ifndef SAVE_DEFSV # define SAVE_DEFSV SAVESPTR(GvSV(PL_defgv)) #endif #ifndef DEFSV_set # define DEFSV_set(sv) (DEFSV = (sv)) #endif /* Older perls (<=5.003) lack AvFILLp */ #ifndef AvFILLp # define AvFILLp AvFILL #endif #ifndef ERRSV # define ERRSV get_sv("@",FALSE) #endif /* Hint: gv_stashpvn * This function's backport doesn't support the length parameter, but * rather ignores it. Portability can only be ensured if the length * parameter is used for speed reasons, but the length can always be * correctly computed from the string argument. */ #ifndef gv_stashpvn # define gv_stashpvn(str,len,create) gv_stashpv(str,create) #endif /* Replace: 1 */ #ifndef get_cv # define get_cv perl_get_cv #endif #ifndef get_sv # define get_sv perl_get_sv #endif #ifndef get_av # define get_av perl_get_av #endif #ifndef get_hv # define get_hv perl_get_hv #endif /* Replace: 0 */ #ifndef dUNDERBAR # define dUNDERBAR dNOOP #endif #ifndef UNDERBAR # define UNDERBAR DEFSV #endif #ifndef dAX # define dAX I32 ax = MARK - PL_stack_base + 1 #endif #ifndef dITEMS # define dITEMS I32 items = SP - MARK #endif #ifndef dXSTARG # define dXSTARG SV * targ = sv_newmortal() #endif #ifndef dAXMARK # define dAXMARK I32 ax = POPMARK; \ register SV ** const mark = PL_stack_base + ax++ #endif #ifndef XSprePUSH # define XSprePUSH (sp = PL_stack_base + ax - 1) #endif #if (PERL_BCDVERSION < 0x5005000) # undef XSRETURN # define XSRETURN(off) \ STMT_START { \ PL_stack_sp = PL_stack_base + ax + ((off) - 1); \ return; \ } STMT_END #endif #ifndef XSPROTO # define XSPROTO(name) void name(pTHX_ CV* cv) #endif #ifndef SVfARG # define SVfARG(p) ((void*)(p)) #endif #ifndef PERL_ABS # define PERL_ABS(x) ((x) < 0 ? -(x) : (x)) #endif #ifndef dVAR # define dVAR dNOOP #endif #ifndef SVf # define SVf "_" #endif #ifndef UTF8_MAXBYTES # define UTF8_MAXBYTES UTF8_MAXLEN #endif #ifndef CPERLscope # define CPERLscope(x) x #endif #ifndef PERL_HASH # define PERL_HASH(hash,str,len) \ STMT_START { \ const char *s_PeRlHaSh = str; \ I32 i_PeRlHaSh = len; \ U32 hash_PeRlHaSh = 0; \ while (i_PeRlHaSh--) \ hash_PeRlHaSh = hash_PeRlHaSh * 33 + *s_PeRlHaSh++; \ (hash) = hash_PeRlHaSh; \ } STMT_END #endif #ifndef PERLIO_FUNCS_DECL # ifdef PERLIO_FUNCS_CONST # define PERLIO_FUNCS_DECL(funcs) const PerlIO_funcs funcs # define PERLIO_FUNCS_CAST(funcs) (PerlIO_funcs*)(funcs) # else # define PERLIO_FUNCS_DECL(funcs) PerlIO_funcs funcs # define PERLIO_FUNCS_CAST(funcs) (funcs) # endif #endif /* provide these typedefs for older perls */ #if (PERL_BCDVERSION < 0x5009003) # ifdef ARGSproto typedef OP* (CPERLscope(*Perl_ppaddr_t))(ARGSproto); # else typedef OP* (CPERLscope(*Perl_ppaddr_t))(pTHX); # endif typedef OP* (CPERLscope(*Perl_check_t)) (pTHX_ OP*); #endif #ifndef isPSXSPC # define isPSXSPC(c) (isSPACE(c) || (c) == '\v') #endif #ifndef isBLANK # define isBLANK(c) ((c) == ' ' || (c) == '\t') #endif #ifdef EBCDIC #ifndef isALNUMC # define isALNUMC(c) isalnum(c) #endif #ifndef isASCII # define isASCII(c) isascii(c) #endif #ifndef isCNTRL # define isCNTRL(c) iscntrl(c) #endif #ifndef isGRAPH # define isGRAPH(c) isgraph(c) #endif #ifndef isPRINT # define isPRINT(c) isprint(c) #endif #ifndef isPUNCT # define isPUNCT(c) ispunct(c) #endif #ifndef isXDIGIT # define isXDIGIT(c) isxdigit(c) #endif #else # if (PERL_BCDVERSION < 0x5010000) /* Hint: isPRINT * The implementation in older perl versions includes all of the * isSPACE() characters, which is wrong. The version provided by * Devel::PPPort always overrides a present buggy version. */ # undef isPRINT # endif #ifndef isALNUMC # define isALNUMC(c) (isALPHA(c) || isDIGIT(c)) #endif #ifndef isASCII # define isASCII(c) ((c) <= 127) #endif #ifndef isCNTRL # define isCNTRL(c) ((c) < ' ' || (c) == 127) #endif #ifndef isGRAPH # define isGRAPH(c) (isALNUM(c) || isPUNCT(c)) #endif #ifndef isPRINT # define isPRINT(c) (((c) >= 32 && (c) < 127)) #endif #ifndef isPUNCT # define isPUNCT(c) (((c) >= 33 && (c) <= 47) || ((c) >= 58 && (c) <= 64) || ((c) >= 91 && (c) <= 96) || ((c) >= 123 && (c) <= 126)) #endif #ifndef isXDIGIT # define isXDIGIT(c) (isDIGIT(c) || ((c) >= 'a' && (c) <= 'f') || ((c) >= 'A' && (c) <= 'F')) #endif #endif #ifndef PERL_SIGNALS_UNSAFE_FLAG #define PERL_SIGNALS_UNSAFE_FLAG 0x0001 #if (PERL_BCDVERSION < 0x5008000) # define D_PPP_PERL_SIGNALS_INIT PERL_SIGNALS_UNSAFE_FLAG #else # define D_PPP_PERL_SIGNALS_INIT 0 #endif #if defined(NEED_PL_signals) static U32 DPPP_(my_PL_signals) = D_PPP_PERL_SIGNALS_INIT; #elif defined(NEED_PL_signals_GLOBAL) U32 DPPP_(my_PL_signals) = D_PPP_PERL_SIGNALS_INIT; #else extern U32 DPPP_(my_PL_signals); #endif #define PL_signals DPPP_(my_PL_signals) #endif /* Hint: PL_ppaddr * Calling an op via PL_ppaddr requires passing a context argument * for threaded builds. Since the context argument is different for * 5.005 perls, you can use aTHXR (supplied by ppport.h), which will * automatically be defined as the correct argument. */ #if (PERL_BCDVERSION <= 0x5005005) /* Replace: 1 */ # define PL_ppaddr ppaddr # define PL_no_modify no_modify /* Replace: 0 */ #endif #if (PERL_BCDVERSION <= 0x5004005) /* Replace: 1 */ # define PL_DBsignal DBsignal # define PL_DBsingle DBsingle # define PL_DBsub DBsub # define PL_DBtrace DBtrace # define PL_Sv Sv # define PL_bufend bufend # define PL_bufptr bufptr # define PL_compiling compiling # define PL_copline copline # define PL_curcop curcop # define PL_curstash curstash # define PL_debstash debstash # define PL_defgv defgv # define PL_diehook diehook # define PL_dirty dirty # define PL_dowarn dowarn # define PL_errgv errgv # define PL_error_count error_count # define PL_expect expect # define PL_hexdigit hexdigit # define PL_hints hints # define PL_in_my in_my # define PL_laststatval laststatval # define PL_lex_state lex_state # define PL_lex_stuff lex_stuff # define PL_linestr linestr # define PL_na na # define PL_perl_destruct_level perl_destruct_level # define PL_perldb perldb # define PL_rsfp_filters rsfp_filters # define PL_rsfp rsfp # define PL_stack_base stack_base # define PL_stack_sp stack_sp # define PL_statcache statcache # define PL_stdingv stdingv # define PL_sv_arenaroot sv_arenaroot # define PL_sv_no sv_no # define PL_sv_undef sv_undef # define PL_sv_yes sv_yes # define PL_tainted tainted # define PL_tainting tainting # define PL_tokenbuf tokenbuf /* Replace: 0 */ #endif /* Warning: PL_parser * For perl versions earlier than 5.9.5, this is an always * non-NULL dummy. Also, it cannot be dereferenced. Don't * use it if you can avoid is and unless you absolutely know * what you're doing. * If you always check that PL_parser is non-NULL, you can * define DPPP_PL_parser_NO_DUMMY to avoid the creation of * a dummy parser structure. */ #if (PERL_BCDVERSION >= 0x5009005) # ifdef DPPP_PL_parser_NO_DUMMY # define D_PPP_my_PL_parser_var(var) ((PL_parser ? PL_parser : \ (croak("panic: PL_parser == NULL in %s:%d", \ __FILE__, __LINE__), (yy_parser *) NULL))->var) # else # ifdef DPPP_PL_parser_NO_DUMMY_WARNING # define D_PPP_parser_dummy_warning(var) # else # define D_PPP_parser_dummy_warning(var) \ warn("warning: dummy PL_" #var " used in %s:%d", __FILE__, __LINE__), # endif # define D_PPP_my_PL_parser_var(var) ((PL_parser ? PL_parser : \ (D_PPP_parser_dummy_warning(var) &DPPP_(dummy_PL_parser)))->var) #if defined(NEED_PL_parser) static yy_parser DPPP_(dummy_PL_parser); #elif defined(NEED_PL_parser_GLOBAL) yy_parser DPPP_(dummy_PL_parser); #else extern yy_parser DPPP_(dummy_PL_parser); #endif # endif /* PL_expect, PL_copline, PL_rsfp, PL_rsfp_filters, PL_linestr, PL_bufptr, PL_bufend, PL_lex_state, PL_lex_stuff, PL_tokenbuf depends on PL_parser */ /* Warning: PL_expect, PL_copline, PL_rsfp, PL_rsfp_filters, PL_linestr, PL_bufptr, PL_bufend, PL_lex_state, PL_lex_stuff, PL_tokenbuf * Do not use this variable unless you know exactly what you're * doint. It is internal to the perl parser and may change or even * be removed in the future. As of perl 5.9.5, you have to check * for (PL_parser != NULL) for this variable to have any effect. * An always non-NULL PL_parser dummy is provided for earlier * perl versions. * If PL_parser is NULL when you try to access this variable, a * dummy is being accessed instead and a warning is issued unless * you define DPPP_PL_parser_NO_DUMMY_WARNING. * If DPPP_PL_parser_NO_DUMMY is defined, the code trying to access * this variable will croak with a panic message. */ # define PL_expect D_PPP_my_PL_parser_var(expect) # define PL_copline D_PPP_my_PL_parser_var(copline) # define PL_rsfp D_PPP_my_PL_parser_var(rsfp) # define PL_rsfp_filters D_PPP_my_PL_parser_var(rsfp_filters) # define PL_linestr D_PPP_my_PL_parser_var(linestr) # define PL_bufptr D_PPP_my_PL_parser_var(bufptr) # define PL_bufend D_PPP_my_PL_parser_var(bufend) # define PL_lex_state D_PPP_my_PL_parser_var(lex_state) # define PL_lex_stuff D_PPP_my_PL_parser_var(lex_stuff) # define PL_tokenbuf D_PPP_my_PL_parser_var(tokenbuf) # define PL_in_my D_PPP_my_PL_parser_var(in_my) # define PL_in_my_stash D_PPP_my_PL_parser_var(in_my_stash) # define PL_error_count D_PPP_my_PL_parser_var(error_count) #else /* ensure that PL_parser != NULL and cannot be dereferenced */ # define PL_parser ((void *) 1) #endif #ifndef mPUSHs # define mPUSHs(s) PUSHs(sv_2mortal(s)) #endif #ifndef PUSHmortal # define PUSHmortal PUSHs(sv_newmortal()) #endif #ifndef mPUSHp # define mPUSHp(p,l) sv_setpvn(PUSHmortal, (p), (l)) #endif #ifndef mPUSHn # define mPUSHn(n) sv_setnv(PUSHmortal, (NV)(n)) #endif #ifndef mPUSHi # define mPUSHi(i) sv_setiv(PUSHmortal, (IV)(i)) #endif #ifndef mPUSHu # define mPUSHu(u) sv_setuv(PUSHmortal, (UV)(u)) #endif #ifndef mXPUSHs # define mXPUSHs(s) XPUSHs(sv_2mortal(s)) #endif #ifndef XPUSHmortal # define XPUSHmortal XPUSHs(sv_newmortal()) #endif #ifndef mXPUSHp # define mXPUSHp(p,l) STMT_START { EXTEND(sp,1); sv_setpvn(PUSHmortal, (p), (l)); } STMT_END #endif #ifndef mXPUSHn # define mXPUSHn(n) STMT_START { EXTEND(sp,1); sv_setnv(PUSHmortal, (NV)(n)); } STMT_END #endif #ifndef mXPUSHi # define mXPUSHi(i) STMT_START { EXTEND(sp,1); sv_setiv(PUSHmortal, (IV)(i)); } STMT_END #endif #ifndef mXPUSHu # define mXPUSHu(u) STMT_START { EXTEND(sp,1); sv_setuv(PUSHmortal, (UV)(u)); } STMT_END #endif /* Replace: 1 */ #ifndef call_sv # define call_sv perl_call_sv #endif #ifndef call_pv # define call_pv perl_call_pv #endif #ifndef call_argv # define call_argv perl_call_argv #endif #ifndef call_method # define call_method perl_call_method #endif #ifndef eval_sv # define eval_sv perl_eval_sv #endif /* Replace: 0 */ #ifndef PERL_LOADMOD_DENY # define PERL_LOADMOD_DENY 0x1 #endif #ifndef PERL_LOADMOD_NOIMPORT # define PERL_LOADMOD_NOIMPORT 0x2 #endif #ifndef PERL_LOADMOD_IMPORT_OPS # define PERL_LOADMOD_IMPORT_OPS 0x4 #endif #ifndef G_METHOD # define G_METHOD 64 # ifdef call_sv # undef call_sv # endif # if (PERL_BCDVERSION < 0x5006000) # define call_sv(sv, flags) ((flags) & G_METHOD ? perl_call_method((char *) SvPV_nolen_const(sv), \ (flags) & ~G_METHOD) : perl_call_sv(sv, flags)) # else # define call_sv(sv, flags) ((flags) & G_METHOD ? Perl_call_method(aTHX_ (char *) SvPV_nolen_const(sv), \ (flags) & ~G_METHOD) : Perl_call_sv(aTHX_ sv, flags)) # endif #endif /* Replace perl_eval_pv with eval_pv */ #ifndef eval_pv #if defined(NEED_eval_pv) static SV* DPPP_(my_eval_pv)(char *p, I32 croak_on_error); static #else extern SV* DPPP_(my_eval_pv)(char *p, I32 croak_on_error); #endif #ifdef eval_pv # undef eval_pv #endif #define eval_pv(a,b) DPPP_(my_eval_pv)(aTHX_ a,b) #define Perl_eval_pv DPPP_(my_eval_pv) #if defined(NEED_eval_pv) || defined(NEED_eval_pv_GLOBAL) SV* DPPP_(my_eval_pv)(char *p, I32 croak_on_error) { dSP; SV* sv = newSVpv(p, 0); PUSHMARK(sp); eval_sv(sv, G_SCALAR); SvREFCNT_dec(sv); SPAGAIN; sv = POPs; PUTBACK; if (croak_on_error && SvTRUE(GvSV(errgv))) croak(SvPVx(GvSV(errgv), na)); return sv; } #endif #endif #ifndef vload_module #if defined(NEED_vload_module) static void DPPP_(my_vload_module)(U32 flags, SV *name, SV *ver, va_list *args); static #else extern void DPPP_(my_vload_module)(U32 flags, SV *name, SV *ver, va_list *args); #endif #ifdef vload_module # undef vload_module #endif #define vload_module(a,b,c,d) DPPP_(my_vload_module)(aTHX_ a,b,c,d) #define Perl_vload_module DPPP_(my_vload_module) #if defined(NEED_vload_module) || defined(NEED_vload_module_GLOBAL) void DPPP_(my_vload_module)(U32 flags, SV *name, SV *ver, va_list *args) { dTHR; dVAR; OP *veop, *imop; OP * const modname = newSVOP(OP_CONST, 0, name); /* 5.005 has a somewhat hacky force_normal that doesn't croak on SvREADONLY() if PL_compling is true. Current perls take care in ck_require() to correctly turn off SvREADONLY before calling force_normal_flags(). This seems a better fix than fudging PL_compling */ SvREADONLY_off(((SVOP*)modname)->op_sv); modname->op_private |= OPpCONST_BARE; if (ver) { veop = newSVOP(OP_CONST, 0, ver); } else veop = NULL; if (flags & PERL_LOADMOD_NOIMPORT) { imop = sawparens(newNULLLIST()); } else if (flags & PERL_LOADMOD_IMPORT_OPS) { imop = va_arg(*args, OP*); } else { SV *sv; imop = NULL; sv = va_arg(*args, SV*); while (sv) { imop = append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv)); sv = va_arg(*args, SV*); } } { const line_t ocopline = PL_copline; COP * const ocurcop = PL_curcop; const int oexpect = PL_expect; #if (PERL_BCDVERSION >= 0x5004000) utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0), veop, modname, imop); #else utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(), modname, imop); #endif PL_expect = oexpect; PL_copline = ocopline; PL_curcop = ocurcop; } } #endif #endif #ifndef load_module #if defined(NEED_load_module) static void DPPP_(my_load_module)(U32 flags, SV *name, SV *ver, ...); static #else extern void DPPP_(my_load_module)(U32 flags, SV *name, SV *ver, ...); #endif #ifdef load_module # undef load_module #endif #define load_module DPPP_(my_load_module) #define Perl_load_module DPPP_(my_load_module) #if defined(NEED_load_module) || defined(NEED_load_module_GLOBAL) void DPPP_(my_load_module)(U32 flags, SV *name, SV *ver, ...) { va_list args; va_start(args, ver); vload_module(flags, name, ver, &args); va_end(args); } #endif #endif #ifndef newRV_inc # define newRV_inc(sv) newRV(sv) /* Replace */ #endif #ifndef newRV_noinc #if defined(NEED_newRV_noinc) static SV * DPPP_(my_newRV_noinc)(SV *sv); static #else extern SV * DPPP_(my_newRV_noinc)(SV *sv); #endif #ifdef newRV_noinc # undef newRV_noinc #endif #define newRV_noinc(a) DPPP_(my_newRV_noinc)(aTHX_ a) #define Perl_newRV_noinc DPPP_(my_newRV_noinc) #if defined(NEED_newRV_noinc) || defined(NEED_newRV_noinc_GLOBAL) SV * DPPP_(my_newRV_noinc)(SV *sv) { SV *rv = (SV *)newRV(sv); SvREFCNT_dec(sv); return rv; } #endif #endif /* Hint: newCONSTSUB * Returns a CV* as of perl-5.7.1. This return value is not supported * by Devel::PPPort. */ /* newCONSTSUB from IO.xs is in the core starting with 5.004_63 */ #if (PERL_BCDVERSION < 0x5004063) && (PERL_BCDVERSION != 0x5004005) #if defined(NEED_newCONSTSUB) static void DPPP_(my_newCONSTSUB)(HV *stash, const char *name, SV *sv); static #else extern void DPPP_(my_newCONSTSUB)(HV *stash, const char *name, SV *sv); #endif #ifdef newCONSTSUB # undef newCONSTSUB #endif #define newCONSTSUB(a,b,c) DPPP_(my_newCONSTSUB)(aTHX_ a,b,c) #define Perl_newCONSTSUB DPPP_(my_newCONSTSUB) #if defined(NEED_newCONSTSUB) || defined(NEED_newCONSTSUB_GLOBAL) /* This is just a trick to avoid a dependency of newCONSTSUB on PL_parser */ /* (There's no PL_parser in perl < 5.005, so this is completely safe) */ #define D_PPP_PL_copline PL_copline void DPPP_(my_newCONSTSUB)(HV *stash, const char *name, SV *sv) { U32 oldhints = PL_hints; HV *old_cop_stash = PL_curcop->cop_stash; HV *old_curstash = PL_curstash; line_t oldline = PL_curcop->cop_line; PL_curcop->cop_line = D_PPP_PL_copline; PL_hints &= ~HINT_BLOCK_SCOPE; if (stash) PL_curstash = PL_curcop->cop_stash = stash; newSUB( #if (PERL_BCDVERSION < 0x5003022) start_subparse(), #elif (PERL_BCDVERSION == 0x5003022) start_subparse(0), #else /* 5.003_23 onwards */ start_subparse(FALSE, 0), #endif newSVOP(OP_CONST, 0, newSVpv((char *) name, 0)), newSVOP(OP_CONST, 0, &PL_sv_no), /* SvPV(&PL_sv_no) == "" -- GMB */ newSTATEOP(0, Nullch, newSVOP(OP_CONST, 0, sv)) ); PL_hints = oldhints; PL_curcop->cop_stash = old_cop_stash; PL_curstash = old_curstash; PL_curcop->cop_line = oldline; } #endif #endif /* * Boilerplate macros for initializing and accessing interpreter-local * data from C. All statics in extensions should be reworked to use * this, if you want to make the extension thread-safe. See ext/re/re.xs * for an example of the use of these macros. * * Code that uses these macros is responsible for the following: * 1. #define MY_CXT_KEY to a unique string, e.g. "DynaLoader_guts" * 2. Declare a typedef named my_cxt_t that is a structure that contains * all the data that needs to be interpreter-local. * 3. Use the START_MY_CXT macro after the declaration of my_cxt_t. * 4. Use the MY_CXT_INIT macro such that it is called exactly once * (typically put in the BOOT: section). * 5. Use the members of the my_cxt_t structure everywhere as * MY_CXT.member. * 6. Use the dMY_CXT macro (a declaration) in all the functions that * access MY_CXT. */ #if defined(MULTIPLICITY) || defined(PERL_OBJECT) || \ defined(PERL_CAPI) || defined(PERL_IMPLICIT_CONTEXT) #ifndef START_MY_CXT /* This must appear in all extensions that define a my_cxt_t structure, * right after the definition (i.e. at file scope). The non-threads * case below uses it to declare the data as static. */ #define START_MY_CXT #if (PERL_BCDVERSION < 0x5004068) /* Fetches the SV that keeps the per-interpreter data. */ #define dMY_CXT_SV \ SV *my_cxt_sv = get_sv(MY_CXT_KEY, FALSE) #else /* >= perl5.004_68 */ #define dMY_CXT_SV \ SV *my_cxt_sv = *hv_fetch(PL_modglobal, MY_CXT_KEY, \ sizeof(MY_CXT_KEY)-1, TRUE) #endif /* < perl5.004_68 */ /* This declaration should be used within all functions that use the * interpreter-local data. */ #define dMY_CXT \ dMY_CXT_SV; \ my_cxt_t *my_cxtp = INT2PTR(my_cxt_t*,SvUV(my_cxt_sv)) /* Creates and zeroes the per-interpreter data. * (We allocate my_cxtp in a Perl SV so that it will be released when * the interpreter goes away.) */ #define MY_CXT_INIT \ dMY_CXT_SV; \ /* newSV() allocates one more than needed */ \ my_cxt_t *my_cxtp = (my_cxt_t*)SvPVX(newSV(sizeof(my_cxt_t)-1));\ Zero(my_cxtp, 1, my_cxt_t); \ sv_setuv(my_cxt_sv, PTR2UV(my_cxtp)) /* This macro must be used to access members of the my_cxt_t structure. * e.g. MYCXT.some_data */ #define MY_CXT (*my_cxtp) /* Judicious use of these macros can reduce the number of times dMY_CXT * is used. Use is similar to pTHX, aTHX etc. */ #define pMY_CXT my_cxt_t *my_cxtp #define pMY_CXT_ pMY_CXT, #define _pMY_CXT ,pMY_CXT #define aMY_CXT my_cxtp #define aMY_CXT_ aMY_CXT, #define _aMY_CXT ,aMY_CXT #endif /* START_MY_CXT */ #ifndef MY_CXT_CLONE /* Clones the per-interpreter data. */ #define MY_CXT_CLONE \ dMY_CXT_SV; \ my_cxt_t *my_cxtp = (my_cxt_t*)SvPVX(newSV(sizeof(my_cxt_t)-1));\ Copy(INT2PTR(my_cxt_t*, SvUV(my_cxt_sv)), my_cxtp, 1, my_cxt_t);\ sv_setuv(my_cxt_sv, PTR2UV(my_cxtp)) #endif #else /* single interpreter */ #ifndef START_MY_CXT #define START_MY_CXT static my_cxt_t my_cxt; #define dMY_CXT_SV dNOOP #define dMY_CXT dNOOP #define MY_CXT_INIT NOOP #define MY_CXT my_cxt #define pMY_CXT void #define pMY_CXT_ #define _pMY_CXT #define aMY_CXT #define aMY_CXT_ #define _aMY_CXT #endif /* START_MY_CXT */ #ifndef MY_CXT_CLONE #define MY_CXT_CLONE NOOP #endif #endif #ifndef IVdf # if IVSIZE == LONGSIZE # define IVdf "ld" # define UVuf "lu" # define UVof "lo" # define UVxf "lx" # define UVXf "lX" # else # if IVSIZE == INTSIZE # define IVdf "d" # define UVuf "u" # define UVof "o" # define UVxf "x" # define UVXf "X" # endif # endif #endif #ifndef NVef # if defined(USE_LONG_DOUBLE) && defined(HAS_LONG_DOUBLE) && \ defined(PERL_PRIfldbl) && (PERL_BCDVERSION != 0x5006000) /* Not very likely, but let's try anyway. */ # define NVef PERL_PRIeldbl # define NVff PERL_PRIfldbl # define NVgf PERL_PRIgldbl # else # define NVef "e" # define NVff "f" # define NVgf "g" # endif #endif #ifndef SvREFCNT_inc # ifdef PERL_USE_GCC_BRACE_GROUPS # define SvREFCNT_inc(sv) \ ({ \ SV * const _sv = (SV*)(sv); \ if (_sv) \ (SvREFCNT(_sv))++; \ _sv; \ }) # else # define SvREFCNT_inc(sv) \ ((PL_Sv=(SV*)(sv)) ? (++(SvREFCNT(PL_Sv)),PL_Sv) : NULL) # endif #endif #ifndef SvREFCNT_inc_simple # ifdef PERL_USE_GCC_BRACE_GROUPS # define SvREFCNT_inc_simple(sv) \ ({ \ if (sv) \ (SvREFCNT(sv))++; \ (SV *)(sv); \ }) # else # define SvREFCNT_inc_simple(sv) \ ((sv) ? (SvREFCNT(sv)++,(SV*)(sv)) : NULL) # endif #endif #ifndef SvREFCNT_inc_NN # ifdef PERL_USE_GCC_BRACE_GROUPS # define SvREFCNT_inc_NN(sv) \ ({ \ SV * const _sv = (SV*)(sv); \ SvREFCNT(_sv)++; \ _sv; \ }) # else # define SvREFCNT_inc_NN(sv) \ (PL_Sv=(SV*)(sv),++(SvREFCNT(PL_Sv)),PL_Sv) # endif #endif #ifndef SvREFCNT_inc_void # ifdef PERL_USE_GCC_BRACE_GROUPS # define SvREFCNT_inc_void(sv) \ ({ \ SV * const _sv = (SV*)(sv); \ if (_sv) \ (void)(SvREFCNT(_sv)++); \ }) # else # define SvREFCNT_inc_void(sv) \ (void)((PL_Sv=(SV*)(sv)) ? ++(SvREFCNT(PL_Sv)) : 0) # endif #endif #ifndef SvREFCNT_inc_simple_void # define SvREFCNT_inc_simple_void(sv) STMT_START { if (sv) SvREFCNT(sv)++; } STMT_END #endif #ifndef SvREFCNT_inc_simple_NN # define SvREFCNT_inc_simple_NN(sv) (++SvREFCNT(sv), (SV*)(sv)) #endif #ifndef SvREFCNT_inc_void_NN # define SvREFCNT_inc_void_NN(sv) (void)(++SvREFCNT((SV*)(sv))) #endif #ifndef SvREFCNT_inc_simple_void_NN # define SvREFCNT_inc_simple_void_NN(sv) (void)(++SvREFCNT((SV*)(sv))) #endif #ifndef newSV_type #if defined(NEED_newSV_type) static SV* DPPP_(my_newSV_type)(pTHX_ svtype const t); static #else extern SV* DPPP_(my_newSV_type)(pTHX_ svtype const t); #endif #ifdef newSV_type # undef newSV_type #endif #define newSV_type(a) DPPP_(my_newSV_type)(aTHX_ a) #define Perl_newSV_type DPPP_(my_newSV_type) #if defined(NEED_newSV_type) || defined(NEED_newSV_type_GLOBAL) SV* DPPP_(my_newSV_type)(pTHX_ svtype const t) { SV* const sv = newSV(0); sv_upgrade(sv, t); return sv; } #endif #endif #if (PERL_BCDVERSION < 0x5006000) # define D_PPP_CONSTPV_ARG(x) ((char *) (x)) #else # define D_PPP_CONSTPV_ARG(x) (x) #endif #ifndef newSVpvn # define newSVpvn(data,len) ((data) \ ? ((len) ? newSVpv((data), (len)) : newSVpv("", 0)) \ : newSV(0)) #endif #ifndef newSVpvn_utf8 # define newSVpvn_utf8(s, len, u) newSVpvn_flags((s), (len), (u) ? SVf_UTF8 : 0) #endif #ifndef SVf_UTF8 # define SVf_UTF8 0 #endif #ifndef newSVpvn_flags #if defined(NEED_newSVpvn_flags) static SV * DPPP_(my_newSVpvn_flags)(pTHX_ const char *s, STRLEN len, U32 flags); static #else extern SV * DPPP_(my_newSVpvn_flags)(pTHX_ const char *s, STRLEN len, U32 flags); #endif #ifdef newSVpvn_flags # undef newSVpvn_flags #endif #define newSVpvn_flags(a,b,c) DPPP_(my_newSVpvn_flags)(aTHX_ a,b,c) #define Perl_newSVpvn_flags DPPP_(my_newSVpvn_flags) #if defined(NEED_newSVpvn_flags) || defined(NEED_newSVpvn_flags_GLOBAL) SV * DPPP_(my_newSVpvn_flags)(pTHX_ const char *s, STRLEN len, U32 flags) { SV *sv = newSVpvn(D_PPP_CONSTPV_ARG(s), len); SvFLAGS(sv) |= (flags & SVf_UTF8); return (flags & SVs_TEMP) ? sv_2mortal(sv) : sv; } #endif #endif /* Backwards compatibility stuff... :-( */ #if !defined(NEED_sv_2pv_flags) && defined(NEED_sv_2pv_nolen) # define NEED_sv_2pv_flags #endif #if !defined(NEED_sv_2pv_flags_GLOBAL) && defined(NEED_sv_2pv_nolen_GLOBAL) # define NEED_sv_2pv_flags_GLOBAL #endif /* Hint: sv_2pv_nolen * Use the SvPV_nolen() or SvPV_nolen_const() macros instead of sv_2pv_nolen(). */ #ifndef sv_2pv_nolen # define sv_2pv_nolen(sv) SvPV_nolen(sv) #endif #ifdef SvPVbyte /* Hint: SvPVbyte * Does not work in perl-5.6.1, ppport.h implements a version * borrowed from perl-5.7.3. */ #if (PERL_BCDVERSION < 0x5007000) #if defined(NEED_sv_2pvbyte) static char * DPPP_(my_sv_2pvbyte)(pTHX_ SV *sv, STRLEN *lp); static #else extern char * DPPP_(my_sv_2pvbyte)(pTHX_ SV *sv, STRLEN *lp); #endif #ifdef sv_2pvbyte # undef sv_2pvbyte #endif #define sv_2pvbyte(a,b) DPPP_(my_sv_2pvbyte)(aTHX_ a,b) #define Perl_sv_2pvbyte DPPP_(my_sv_2pvbyte) #if defined(NEED_sv_2pvbyte) || defined(NEED_sv_2pvbyte_GLOBAL) char * DPPP_(my_sv_2pvbyte)(pTHX_ SV *sv, STRLEN *lp) { sv_utf8_downgrade(sv,0); return SvPV(sv,*lp); } #endif /* Hint: sv_2pvbyte * Use the SvPVbyte() macro instead of sv_2pvbyte(). */ #undef SvPVbyte #define SvPVbyte(sv, lp) \ ((SvFLAGS(sv) & (SVf_POK|SVf_UTF8)) == (SVf_POK) \ ? ((lp = SvCUR(sv)), SvPVX(sv)) : sv_2pvbyte(sv, &lp)) #endif #else # define SvPVbyte SvPV # define sv_2pvbyte sv_2pv #endif #ifndef sv_2pvbyte_nolen # define sv_2pvbyte_nolen(sv) sv_2pv_nolen(sv) #endif /* Hint: sv_pvn * Always use the SvPV() macro instead of sv_pvn(). */ /* Hint: sv_pvn_force * Always use the SvPV_force() macro instead of sv_pvn_force(). */ /* If these are undefined, they're not handled by the core anyway */ #ifndef SV_IMMEDIATE_UNREF # define SV_IMMEDIATE_UNREF 0 #endif #ifndef SV_GMAGIC # define SV_GMAGIC 0 #endif #ifndef SV_COW_DROP_PV # define SV_COW_DROP_PV 0 #endif #ifndef SV_UTF8_NO_ENCODING # define SV_UTF8_NO_ENCODING 0 #endif #ifndef SV_NOSTEAL # define SV_NOSTEAL 0 #endif #ifndef SV_CONST_RETURN # define SV_CONST_RETURN 0 #endif #ifndef SV_MUTABLE_RETURN # define SV_MUTABLE_RETURN 0 #endif #ifndef SV_SMAGIC # define SV_SMAGIC 0 #endif #ifndef SV_HAS_TRAILING_NUL # define SV_HAS_TRAILING_NUL 0 #endif #ifndef SV_COW_SHARED_HASH_KEYS # define SV_COW_SHARED_HASH_KEYS 0 #endif #if (PERL_BCDVERSION < 0x5007002) #if defined(NEED_sv_2pv_flags) static char * DPPP_(my_sv_2pv_flags)(pTHX_ SV *sv, STRLEN *lp, I32 flags); static #else extern char * DPPP_(my_sv_2pv_flags)(pTHX_ SV *sv, STRLEN *lp, I32 flags); #endif #ifdef sv_2pv_flags # undef sv_2pv_flags #endif #define sv_2pv_flags(a,b,c) DPPP_(my_sv_2pv_flags)(aTHX_ a,b,c) #define Perl_sv_2pv_flags DPPP_(my_sv_2pv_flags) #if defined(NEED_sv_2pv_flags) || defined(NEED_sv_2pv_flags_GLOBAL) char * DPPP_(my_sv_2pv_flags)(pTHX_ SV *sv, STRLEN *lp, I32 flags) { STRLEN n_a = (STRLEN) flags; return sv_2pv(sv, lp ? lp : &n_a); } #endif #if defined(NEED_sv_pvn_force_flags) static char * DPPP_(my_sv_pvn_force_flags)(pTHX_ SV *sv, STRLEN *lp, I32 flags); static #else extern char * DPPP_(my_sv_pvn_force_flags)(pTHX_ SV *sv, STRLEN *lp, I32 flags); #endif #ifdef sv_pvn_force_flags # undef sv_pvn_force_flags #endif #define sv_pvn_force_flags(a,b,c) DPPP_(my_sv_pvn_force_flags)(aTHX_ a,b,c) #define Perl_sv_pvn_force_flags DPPP_(my_sv_pvn_force_flags) #if defined(NEED_sv_pvn_force_flags) || defined(NEED_sv_pvn_force_flags_GLOBAL) char * DPPP_(my_sv_pvn_force_flags)(pTHX_ SV *sv, STRLEN *lp, I32 flags) { STRLEN n_a = (STRLEN) flags; return sv_pvn_force(sv, lp ? lp : &n_a); } #endif #endif #if (PERL_BCDVERSION < 0x5008008) || ( (PERL_BCDVERSION >= 0x5009000) && (PERL_BCDVERSION < 0x5009003) ) # define DPPP_SVPV_NOLEN_LP_ARG &PL_na #else # define DPPP_SVPV_NOLEN_LP_ARG 0 #endif #ifndef SvPV_const # define SvPV_const(sv, lp) SvPV_flags_const(sv, lp, SV_GMAGIC) #endif #ifndef SvPV_mutable # define SvPV_mutable(sv, lp) SvPV_flags_mutable(sv, lp, SV_GMAGIC) #endif #ifndef SvPV_flags # define SvPV_flags(sv, lp, flags) \ ((SvFLAGS(sv) & (SVf_POK)) == SVf_POK \ ? ((lp = SvCUR(sv)), SvPVX(sv)) : sv_2pv_flags(sv, &lp, flags)) #endif #ifndef SvPV_flags_const # define SvPV_flags_const(sv, lp, flags) \ ((SvFLAGS(sv) & (SVf_POK)) == SVf_POK \ ? ((lp = SvCUR(sv)), SvPVX_const(sv)) : \ (const char*) sv_2pv_flags(sv, &lp, flags|SV_CONST_RETURN)) #endif #ifndef SvPV_flags_const_nolen # define SvPV_flags_const_nolen(sv, flags) \ ((SvFLAGS(sv) & (SVf_POK)) == SVf_POK \ ? SvPVX_const(sv) : \ (const char*) sv_2pv_flags(sv, DPPP_SVPV_NOLEN_LP_ARG, flags|SV_CONST_RETURN)) #endif #ifndef SvPV_flags_mutable # define SvPV_flags_mutable(sv, lp, flags) \ ((SvFLAGS(sv) & (SVf_POK)) == SVf_POK \ ? ((lp = SvCUR(sv)), SvPVX_mutable(sv)) : \ sv_2pv_flags(sv, &lp, flags|SV_MUTABLE_RETURN)) #endif #ifndef SvPV_force # define SvPV_force(sv, lp) SvPV_force_flags(sv, lp, SV_GMAGIC) #endif #ifndef SvPV_force_nolen # define SvPV_force_nolen(sv) SvPV_force_flags_nolen(sv, SV_GMAGIC) #endif #ifndef SvPV_force_mutable # define SvPV_force_mutable(sv, lp) SvPV_force_flags_mutable(sv, lp, SV_GMAGIC) #endif #ifndef SvPV_force_nomg # define SvPV_force_nomg(sv, lp) SvPV_force_flags(sv, lp, 0) #endif #ifndef SvPV_force_nomg_nolen # define SvPV_force_nomg_nolen(sv) SvPV_force_flags_nolen(sv, 0) #endif #ifndef SvPV_force_flags # define SvPV_force_flags(sv, lp, flags) \ ((SvFLAGS(sv) & (SVf_POK|SVf_THINKFIRST)) == SVf_POK \ ? ((lp = SvCUR(sv)), SvPVX(sv)) : sv_pvn_force_flags(sv, &lp, flags)) #endif #ifndef SvPV_force_flags_nolen # define SvPV_force_flags_nolen(sv, flags) \ ((SvFLAGS(sv) & (SVf_POK|SVf_THINKFIRST)) == SVf_POK \ ? SvPVX(sv) : sv_pvn_force_flags(sv, DPPP_SVPV_NOLEN_LP_ARG, flags)) #endif #ifndef SvPV_force_flags_mutable # define SvPV_force_flags_mutable(sv, lp, flags) \ ((SvFLAGS(sv) & (SVf_POK|SVf_THINKFIRST)) == SVf_POK \ ? ((lp = SvCUR(sv)), SvPVX_mutable(sv)) \ : sv_pvn_force_flags(sv, &lp, flags|SV_MUTABLE_RETURN)) #endif #ifndef SvPV_nolen # define SvPV_nolen(sv) \ ((SvFLAGS(sv) & (SVf_POK)) == SVf_POK \ ? SvPVX(sv) : sv_2pv_flags(sv, DPPP_SVPV_NOLEN_LP_ARG, SV_GMAGIC)) #endif #ifndef SvPV_nolen_const # define SvPV_nolen_const(sv) \ ((SvFLAGS(sv) & (SVf_POK)) == SVf_POK \ ? SvPVX_const(sv) : sv_2pv_flags(sv, DPPP_SVPV_NOLEN_LP_ARG, SV_GMAGIC|SV_CONST_RETURN)) #endif #ifndef SvPV_nomg # define SvPV_nomg(sv, lp) SvPV_flags(sv, lp, 0) #endif #ifndef SvPV_nomg_const # define SvPV_nomg_const(sv, lp) SvPV_flags_const(sv, lp, 0) #endif #ifndef SvPV_nomg_const_nolen # define SvPV_nomg_const_nolen(sv) SvPV_flags_const_nolen(sv, 0) #endif #ifndef SvPV_renew # define SvPV_renew(sv,n) STMT_START { SvLEN_set(sv, n); \ SvPV_set((sv), (char *) saferealloc( \ (Malloc_t)SvPVX(sv), (MEM_SIZE)((n)))); \ } STMT_END #endif #ifndef SvMAGIC_set # define SvMAGIC_set(sv, val) \ STMT_START { assert(SvTYPE(sv) >= SVt_PVMG); \ (((XPVMG*) SvANY(sv))->xmg_magic = (val)); } STMT_END #endif #if (PERL_BCDVERSION < 0x5009003) #ifndef SvPVX_const # define SvPVX_const(sv) ((const char*) (0 + SvPVX(sv))) #endif #ifndef SvPVX_mutable # define SvPVX_mutable(sv) (0 + SvPVX(sv)) #endif #ifndef SvRV_set # define SvRV_set(sv, val) \ STMT_START { assert(SvTYPE(sv) >= SVt_RV); \ (((XRV*) SvANY(sv))->xrv_rv = (val)); } STMT_END #endif #else #ifndef SvPVX_const # define SvPVX_const(sv) ((const char*)((sv)->sv_u.svu_pv)) #endif #ifndef SvPVX_mutable # define SvPVX_mutable(sv) ((sv)->sv_u.svu_pv) #endif #ifndef SvRV_set # define SvRV_set(sv, val) \ STMT_START { assert(SvTYPE(sv) >= SVt_RV); \ ((sv)->sv_u.svu_rv = (val)); } STMT_END #endif #endif #ifndef SvSTASH_set # define SvSTASH_set(sv, val) \ STMT_START { assert(SvTYPE(sv) >= SVt_PVMG); \ (((XPVMG*) SvANY(sv))->xmg_stash = (val)); } STMT_END #endif #if (PERL_BCDVERSION < 0x5004000) #ifndef SvUV_set # define SvUV_set(sv, val) \ STMT_START { assert(SvTYPE(sv) == SVt_IV || SvTYPE(sv) >= SVt_PVIV); \ (((XPVIV*) SvANY(sv))->xiv_iv = (IV) (val)); } STMT_END #endif #else #ifndef SvUV_set # define SvUV_set(sv, val) \ STMT_START { assert(SvTYPE(sv) == SVt_IV || SvTYPE(sv) >= SVt_PVIV); \ (((XPVUV*) SvANY(sv))->xuv_uv = (val)); } STMT_END #endif #endif #if (PERL_BCDVERSION >= 0x5004000) && !defined(vnewSVpvf) #if defined(NEED_vnewSVpvf) static SV * DPPP_(my_vnewSVpvf)(pTHX_ const char *pat, va_list *args); static #else extern SV * DPPP_(my_vnewSVpvf)(pTHX_ const char *pat, va_list *args); #endif #ifdef vnewSVpvf # undef vnewSVpvf #endif #define vnewSVpvf(a,b) DPPP_(my_vnewSVpvf)(aTHX_ a,b) #define Perl_vnewSVpvf DPPP_(my_vnewSVpvf) #if defined(NEED_vnewSVpvf) || defined(NEED_vnewSVpvf_GLOBAL) SV * DPPP_(my_vnewSVpvf)(pTHX_ const char *pat, va_list *args) { register SV *sv = newSV(0); sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*)); return sv; } #endif #endif #if (PERL_BCDVERSION >= 0x5004000) && !defined(sv_vcatpvf) # define sv_vcatpvf(sv, pat, args) sv_vcatpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*)) #endif #if (PERL_BCDVERSION >= 0x5004000) && !defined(sv_vsetpvf) # define sv_vsetpvf(sv, pat, args) sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*)) #endif #if (PERL_BCDVERSION >= 0x5004000) && !defined(sv_catpvf_mg) #if defined(NEED_sv_catpvf_mg) static void DPPP_(my_sv_catpvf_mg)(pTHX_ SV *sv, const char *pat, ...); static #else extern void DPPP_(my_sv_catpvf_mg)(pTHX_ SV *sv, const char *pat, ...); #endif #define Perl_sv_catpvf_mg DPPP_(my_sv_catpvf_mg) #if defined(NEED_sv_catpvf_mg) || defined(NEED_sv_catpvf_mg_GLOBAL) void DPPP_(my_sv_catpvf_mg)(pTHX_ SV *sv, const char *pat, ...) { va_list args; va_start(args, pat); sv_vcatpvfn(sv, pat, strlen(pat), &args, Null(SV**), 0, Null(bool*)); SvSETMAGIC(sv); va_end(args); } #endif #endif #ifdef PERL_IMPLICIT_CONTEXT #if (PERL_BCDVERSION >= 0x5004000) && !defined(sv_catpvf_mg_nocontext) #if defined(NEED_sv_catpvf_mg_nocontext) static void DPPP_(my_sv_catpvf_mg_nocontext)(SV *sv, const char *pat, ...); static #else extern void DPPP_(my_sv_catpvf_mg_nocontext)(SV *sv, const char *pat, ...); #endif #define sv_catpvf_mg_nocontext DPPP_(my_sv_catpvf_mg_nocontext) #define Perl_sv_catpvf_mg_nocontext DPPP_(my_sv_catpvf_mg_nocontext) #if defined(NEED_sv_catpvf_mg_nocontext) || defined(NEED_sv_catpvf_mg_nocontext_GLOBAL) void DPPP_(my_sv_catpvf_mg_nocontext)(SV *sv, const char *pat, ...) { dTHX; va_list args; va_start(args, pat); sv_vcatpvfn(sv, pat, strlen(pat), &args, Null(SV**), 0, Null(bool*)); SvSETMAGIC(sv); va_end(args); } #endif #endif #endif /* sv_catpvf_mg depends on sv_catpvf_mg_nocontext */ #ifndef sv_catpvf_mg # ifdef PERL_IMPLICIT_CONTEXT # define sv_catpvf_mg Perl_sv_catpvf_mg_nocontext # else # define sv_catpvf_mg Perl_sv_catpvf_mg # endif #endif #if (PERL_BCDVERSION >= 0x5004000) && !defined(sv_vcatpvf_mg) # define sv_vcatpvf_mg(sv, pat, args) \ STMT_START { \ sv_vcatpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*)); \ SvSETMAGIC(sv); \ } STMT_END #endif #if (PERL_BCDVERSION >= 0x5004000) && !defined(sv_setpvf_mg) #if defined(NEED_sv_setpvf_mg) static void DPPP_(my_sv_setpvf_mg)(pTHX_ SV *sv, const char *pat, ...); static #else extern void DPPP_(my_sv_setpvf_mg)(pTHX_ SV *sv, const char *pat, ...); #endif #define Perl_sv_setpvf_mg DPPP_(my_sv_setpvf_mg) #if defined(NEED_sv_setpvf_mg) || defined(NEED_sv_setpvf_mg_GLOBAL) void DPPP_(my_sv_setpvf_mg)(pTHX_ SV *sv, const char *pat, ...) { va_list args; va_start(args, pat); sv_vsetpvfn(sv, pat, strlen(pat), &args, Null(SV**), 0, Null(bool*)); SvSETMAGIC(sv); va_end(args); } #endif #endif #ifdef PERL_IMPLICIT_CONTEXT #if (PERL_BCDVERSION >= 0x5004000) && !defined(sv_setpvf_mg_nocontext) #if defined(NEED_sv_setpvf_mg_nocontext) static void DPPP_(my_sv_setpvf_mg_nocontext)(SV *sv, const char *pat, ...); static #else extern void DPPP_(my_sv_setpvf_mg_nocontext)(SV *sv, const char *pat, ...); #endif #define sv_setpvf_mg_nocontext DPPP_(my_sv_setpvf_mg_nocontext) #define Perl_sv_setpvf_mg_nocontext DPPP_(my_sv_setpvf_mg_nocontext) #if defined(NEED_sv_setpvf_mg_nocontext) || defined(NEED_sv_setpvf_mg_nocontext_GLOBAL) void DPPP_(my_sv_setpvf_mg_nocontext)(SV *sv, const char *pat, ...) { dTHX; va_list args; va_start(args, pat); sv_vsetpvfn(sv, pat, strlen(pat), &args, Null(SV**), 0, Null(bool*)); SvSETMAGIC(sv); va_end(args); } #endif #endif #endif /* sv_setpvf_mg depends on sv_setpvf_mg_nocontext */ #ifndef sv_setpvf_mg # ifdef PERL_IMPLICIT_CONTEXT # define sv_setpvf_mg Perl_sv_setpvf_mg_nocontext # else # define sv_setpvf_mg Perl_sv_setpvf_mg # endif #endif #if (PERL_BCDVERSION >= 0x5004000) && !defined(sv_vsetpvf_mg) # define sv_vsetpvf_mg(sv, pat, args) \ STMT_START { \ sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*)); \ SvSETMAGIC(sv); \ } STMT_END #endif #ifndef newSVpvn_share #if defined(NEED_newSVpvn_share) static SV * DPPP_(my_newSVpvn_share)(pTHX_ const char *src, I32 len, U32 hash); static #else extern SV * DPPP_(my_newSVpvn_share)(pTHX_ const char *src, I32 len, U32 hash); #endif #ifdef newSVpvn_share # undef newSVpvn_share #endif #define newSVpvn_share(a,b,c) DPPP_(my_newSVpvn_share)(aTHX_ a,b,c) #define Perl_newSVpvn_share DPPP_(my_newSVpvn_share) #if defined(NEED_newSVpvn_share) || defined(NEED_newSVpvn_share_GLOBAL) SV * DPPP_(my_newSVpvn_share)(pTHX_ const char *src, I32 len, U32 hash) { SV *sv; if (len < 0) len = -len; if (!hash) PERL_HASH(hash, (char*) src, len); sv = newSVpvn((char *) src, len); sv_upgrade(sv, SVt_PVIV); SvIVX(sv) = hash; SvREADONLY_on(sv); SvPOK_on(sv); return sv; } #endif #endif #ifndef SvSHARED_HASH # define SvSHARED_HASH(sv) (0 + SvUVX(sv)) #endif #ifndef HvNAME_get # define HvNAME_get(hv) HvNAME(hv) #endif #ifndef HvNAMELEN_get # define HvNAMELEN_get(hv) (HvNAME_get(hv) ? (I32)strlen(HvNAME_get(hv)) : 0) #endif #ifndef GvSVn # define GvSVn(gv) GvSV(gv) #endif #ifndef isGV_with_GP # define isGV_with_GP(gv) isGV(gv) #endif #ifndef WARN_ALL # define WARN_ALL 0 #endif #ifndef WARN_CLOSURE # define WARN_CLOSURE 1 #endif #ifndef WARN_DEPRECATED # define WARN_DEPRECATED 2 #endif #ifndef WARN_EXITING # define WARN_EXITING 3 #endif #ifndef WARN_GLOB # define WARN_GLOB 4 #endif #ifndef WARN_IO # define WARN_IO 5 #endif #ifndef WARN_CLOSED # define WARN_CLOSED 6 #endif #ifndef WARN_EXEC # define WARN_EXEC 7 #endif #ifndef WARN_LAYER # define WARN_LAYER 8 #endif #ifndef WARN_NEWLINE # define WARN_NEWLINE 9 #endif #ifndef WARN_PIPE # define WARN_PIPE 10 #endif #ifndef WARN_UNOPENED # define WARN_UNOPENED 11 #endif #ifndef WARN_MISC # define WARN_MISC 12 #endif #ifndef WARN_NUMERIC # define WARN_NUMERIC 13 #endif #ifndef WARN_ONCE # define WARN_ONCE 14 #endif #ifndef WARN_OVERFLOW # define WARN_OVERFLOW 15 #endif #ifndef WARN_PACK # define WARN_PACK 16 #endif #ifndef WARN_PORTABLE # define WARN_PORTABLE 17 #endif #ifndef WARN_RECURSION # define WARN_RECURSION 18 #endif #ifndef WARN_REDEFINE # define WARN_REDEFINE 19 #endif #ifndef WARN_REGEXP # define WARN_REGEXP 20 #endif #ifndef WARN_SEVERE # define WARN_SEVERE 21 #endif #ifndef WARN_DEBUGGING # define WARN_DEBUGGING 22 #endif #ifndef WARN_INPLACE # define WARN_INPLACE 23 #endif #ifndef WARN_INTERNAL # define WARN_INTERNAL 24 #endif #ifndef WARN_MALLOC # define WARN_MALLOC 25 #endif #ifndef WARN_SIGNAL # define WARN_SIGNAL 26 #endif #ifndef WARN_SUBSTR # define WARN_SUBSTR 27 #endif #ifndef WARN_SYNTAX # define WARN_SYNTAX 28 #endif #ifndef WARN_AMBIGUOUS # define WARN_AMBIGUOUS 29 #endif #ifndef WARN_BAREWORD # define WARN_BAREWORD 30 #endif #ifndef WARN_DIGIT # define WARN_DIGIT 31 #endif #ifndef WARN_PARENTHESIS # define WARN_PARENTHESIS 32 #endif #ifndef WARN_PRECEDENCE # define WARN_PRECEDENCE 33 #endif #ifndef WARN_PRINTF # define WARN_PRINTF 34 #endif #ifndef WARN_PROTOTYPE # define WARN_PROTOTYPE 35 #endif #ifndef WARN_QW # define WARN_QW 36 #endif #ifndef WARN_RESERVED # define WARN_RESERVED 37 #endif #ifndef WARN_SEMICOLON # define WARN_SEMICOLON 38 #endif #ifndef WARN_TAINT # define WARN_TAINT 39 #endif #ifndef WARN_THREADS # define WARN_THREADS 40 #endif #ifndef WARN_UNINITIALIZED # define WARN_UNINITIALIZED 41 #endif #ifndef WARN_UNPACK # define WARN_UNPACK 42 #endif #ifndef WARN_UNTIE # define WARN_UNTIE 43 #endif #ifndef WARN_UTF8 # define WARN_UTF8 44 #endif #ifndef WARN_VOID # define WARN_VOID 45 #endif #ifndef WARN_ASSERTIONS # define WARN_ASSERTIONS 46 #endif #ifndef packWARN # define packWARN(a) (a) #endif #ifndef ckWARN # ifdef G_WARN_ON # define ckWARN(a) (PL_dowarn & G_WARN_ON) # else # define ckWARN(a) PL_dowarn # endif #endif #if (PERL_BCDVERSION >= 0x5004000) && !defined(warner) #if defined(NEED_warner) static void DPPP_(my_warner)(U32 err, const char *pat, ...); static #else extern void DPPP_(my_warner)(U32 err, const char *pat, ...); #endif #define Perl_warner DPPP_(my_warner) #if defined(NEED_warner) || defined(NEED_warner_GLOBAL) void DPPP_(my_warner)(U32 err, const char *pat, ...) { SV *sv; va_list args; PERL_UNUSED_ARG(err); va_start(args, pat); sv = vnewSVpvf(pat, &args); va_end(args); sv_2mortal(sv); warn("%s", SvPV_nolen(sv)); } #define warner Perl_warner #define Perl_warner_nocontext Perl_warner #endif #endif /* concatenating with "" ensures that only literal strings are accepted as argument * note that STR_WITH_LEN() can't be used as argument to macros or functions that * under some configurations might be macros */ #ifndef STR_WITH_LEN # define STR_WITH_LEN(s) (s ""), (sizeof(s)-1) #endif #ifndef newSVpvs # define newSVpvs(str) newSVpvn(str "", sizeof(str) - 1) #endif #ifndef newSVpvs_flags # define newSVpvs_flags(str, flags) newSVpvn_flags(str "", sizeof(str) - 1, flags) #endif #ifndef sv_catpvs # define sv_catpvs(sv, str) sv_catpvn(sv, str "", sizeof(str) - 1) #endif #ifndef sv_setpvs # define sv_setpvs(sv, str) sv_setpvn(sv, str "", sizeof(str) - 1) #endif #ifndef hv_fetchs # define hv_fetchs(hv, key, lval) hv_fetch(hv, key "", sizeof(key) - 1, lval) #endif #ifndef hv_stores # define hv_stores(hv, key, val) hv_store(hv, key "", sizeof(key) - 1, val, 0) #endif #ifndef gv_fetchpvn_flags # define gv_fetchpvn_flags(name, len, flags, svt) gv_fetchpv(name, flags, svt) #endif #ifndef gv_fetchpvs # define gv_fetchpvs(name, flags, svt) gv_fetchpvn_flags(name "", sizeof(name) - 1, flags, svt) #endif #ifndef gv_stashpvs # define gv_stashpvs(name, flags) gv_stashpvn(name "", sizeof(name) - 1, flags) #endif #ifndef SvGETMAGIC # define SvGETMAGIC(x) STMT_START { if (SvGMAGICAL(x)) mg_get(x); } STMT_END #endif #ifndef PERL_MAGIC_sv # define PERL_MAGIC_sv '\0' #endif #ifndef PERL_MAGIC_overload # define PERL_MAGIC_overload 'A' #endif #ifndef PERL_MAGIC_overload_elem # define PERL_MAGIC_overload_elem 'a' #endif #ifndef PERL_MAGIC_overload_table # define PERL_MAGIC_overload_table 'c' #endif #ifndef PERL_MAGIC_bm # define PERL_MAGIC_bm 'B' #endif #ifndef PERL_MAGIC_regdata # define PERL_MAGIC_regdata 'D' #endif #ifndef PERL_MAGIC_regdatum # define PERL_MAGIC_regdatum 'd' #endif #ifndef PERL_MAGIC_env # define PERL_MAGIC_env 'E' #endif #ifndef PERL_MAGIC_envelem # define PERL_MAGIC_envelem 'e' #endif #ifndef PERL_MAGIC_fm # define PERL_MAGIC_fm 'f' #endif #ifndef PERL_MAGIC_regex_global # define PERL_MAGIC_regex_global 'g' #endif #ifndef PERL_MAGIC_isa # define PERL_MAGIC_isa 'I' #endif #ifndef PERL_MAGIC_isaelem # define PERL_MAGIC_isaelem 'i' #endif #ifndef PERL_MAGIC_nkeys # define PERL_MAGIC_nkeys 'k' #endif #ifndef PERL_MAGIC_dbfile # define PERL_MAGIC_dbfile 'L' #endif #ifndef PERL_MAGIC_dbline # define PERL_MAGIC_dbline 'l' #endif #ifndef PERL_MAGIC_mutex # define PERL_MAGIC_mutex 'm' #endif #ifndef PERL_MAGIC_shared # define PERL_MAGIC_shared 'N' #endif #ifndef PERL_MAGIC_shared_scalar # define PERL_MAGIC_shared_scalar 'n' #endif #ifndef PERL_MAGIC_collxfrm # define PERL_MAGIC_collxfrm 'o' #endif #ifndef PERL_MAGIC_tied # define PERL_MAGIC_tied 'P' #endif #ifndef PERL_MAGIC_tiedelem # define PERL_MAGIC_tiedelem 'p' #endif #ifndef PERL_MAGIC_tiedscalar # define PERL_MAGIC_tiedscalar 'q' #endif #ifndef PERL_MAGIC_qr # define PERL_MAGIC_qr 'r' #endif #ifndef PERL_MAGIC_sig # define PERL_MAGIC_sig 'S' #endif #ifndef PERL_MAGIC_sigelem # define PERL_MAGIC_sigelem 's' #endif #ifndef PERL_MAGIC_taint # define PERL_MAGIC_taint 't' #endif #ifndef PERL_MAGIC_uvar # define PERL_MAGIC_uvar 'U' #endif #ifndef PERL_MAGIC_uvar_elem # define PERL_MAGIC_uvar_elem 'u' #endif #ifndef PERL_MAGIC_vstring # define PERL_MAGIC_vstring 'V' #endif #ifndef PERL_MAGIC_vec # define PERL_MAGIC_vec 'v' #endif #ifndef PERL_MAGIC_utf8 # define PERL_MAGIC_utf8 'w' #endif #ifndef PERL_MAGIC_substr # define PERL_MAGIC_substr 'x' #endif #ifndef PERL_MAGIC_defelem # define PERL_MAGIC_defelem 'y' #endif #ifndef PERL_MAGIC_glob # define PERL_MAGIC_glob '*' #endif #ifndef PERL_MAGIC_arylen # define PERL_MAGIC_arylen '#' #endif #ifndef PERL_MAGIC_pos # define PERL_MAGIC_pos '.' #endif #ifndef PERL_MAGIC_backref # define PERL_MAGIC_backref '<' #endif #ifndef PERL_MAGIC_ext # define PERL_MAGIC_ext '~' #endif /* That's the best we can do... */ #ifndef sv_catpvn_nomg # define sv_catpvn_nomg sv_catpvn #endif #ifndef sv_catsv_nomg # define sv_catsv_nomg sv_catsv #endif #ifndef sv_setsv_nomg # define sv_setsv_nomg sv_setsv #endif #ifndef sv_pvn_nomg # define sv_pvn_nomg sv_pvn #endif #ifndef SvIV_nomg # define SvIV_nomg SvIV #endif #ifndef SvUV_nomg # define SvUV_nomg SvUV #endif #ifndef sv_catpv_mg # define sv_catpv_mg(sv, ptr) \ STMT_START { \ SV *TeMpSv = sv; \ sv_catpv(TeMpSv,ptr); \ SvSETMAGIC(TeMpSv); \ } STMT_END #endif #ifndef sv_catpvn_mg # define sv_catpvn_mg(sv, ptr, len) \ STMT_START { \ SV *TeMpSv = sv; \ sv_catpvn(TeMpSv,ptr,len); \ SvSETMAGIC(TeMpSv); \ } STMT_END #endif #ifndef sv_catsv_mg # define sv_catsv_mg(dsv, ssv) \ STMT_START { \ SV *TeMpSv = dsv; \ sv_catsv(TeMpSv,ssv); \ SvSETMAGIC(TeMpSv); \ } STMT_END #endif #ifndef sv_setiv_mg # define sv_setiv_mg(sv, i) \ STMT_START { \ SV *TeMpSv = sv; \ sv_setiv(TeMpSv,i); \ SvSETMAGIC(TeMpSv); \ } STMT_END #endif #ifndef sv_setnv_mg # define sv_setnv_mg(sv, num) \ STMT_START { \ SV *TeMpSv = sv; \ sv_setnv(TeMpSv,num); \ SvSETMAGIC(TeMpSv); \ } STMT_END #endif #ifndef sv_setpv_mg # define sv_setpv_mg(sv, ptr) \ STMT_START { \ SV *TeMpSv = sv; \ sv_setpv(TeMpSv,ptr); \ SvSETMAGIC(TeMpSv); \ } STMT_END #endif #ifndef sv_setpvn_mg # define sv_setpvn_mg(sv, ptr, len) \ STMT_START { \ SV *TeMpSv = sv; \ sv_setpvn(TeMpSv,ptr,len); \ SvSETMAGIC(TeMpSv); \ } STMT_END #endif #ifndef sv_setsv_mg # define sv_setsv_mg(dsv, ssv) \ STMT_START { \ SV *TeMpSv = dsv; \ sv_setsv(TeMpSv,ssv); \ SvSETMAGIC(TeMpSv); \ } STMT_END #endif #ifndef sv_setuv_mg # define sv_setuv_mg(sv, i) \ STMT_START { \ SV *TeMpSv = sv; \ sv_setuv(TeMpSv,i); \ SvSETMAGIC(TeMpSv); \ } STMT_END #endif #ifndef sv_usepvn_mg # define sv_usepvn_mg(sv, ptr, len) \ STMT_START { \ SV *TeMpSv = sv; \ sv_usepvn(TeMpSv,ptr,len); \ SvSETMAGIC(TeMpSv); \ } STMT_END #endif #ifndef SvVSTRING_mg # define SvVSTRING_mg(sv) (SvMAGICAL(sv) ? mg_find(sv, PERL_MAGIC_vstring) : NULL) #endif /* Hint: sv_magic_portable * This is a compatibility function that is only available with * Devel::PPPort. It is NOT in the perl core. * Its purpose is to mimic the 5.8.0 behaviour of sv_magic() when * it is being passed a name pointer with namlen == 0. In that * case, perl 5.8.0 and later store the pointer, not a copy of it. * The compatibility can be provided back to perl 5.004. With * earlier versions, the code will not compile. */ #if (PERL_BCDVERSION < 0x5004000) /* code that uses sv_magic_portable will not compile */ #elif (PERL_BCDVERSION < 0x5008000) # define sv_magic_portable(sv, obj, how, name, namlen) \ STMT_START { \ SV *SvMp_sv = (sv); \ char *SvMp_name = (char *) (name); \ I32 SvMp_namlen = (namlen); \ if (SvMp_name && SvMp_namlen == 0) \ { \ MAGIC *mg; \ sv_magic(SvMp_sv, obj, how, 0, 0); \ mg = SvMAGIC(SvMp_sv); \ mg->mg_len = -42; /* XXX: this is the tricky part */ \ mg->mg_ptr = SvMp_name; \ } \ else \ { \ sv_magic(SvMp_sv, obj, how, SvMp_name, SvMp_namlen); \ } \ } STMT_END #else # define sv_magic_portable(a, b, c, d, e) sv_magic(a, b, c, d, e) #endif #ifdef USE_ITHREADS #ifndef CopFILE # define CopFILE(c) ((c)->cop_file) #endif #ifndef CopFILEGV # define CopFILEGV(c) (CopFILE(c) ? gv_fetchfile(CopFILE(c)) : Nullgv) #endif #ifndef CopFILE_set # define CopFILE_set(c,pv) ((c)->cop_file = savepv(pv)) #endif #ifndef CopFILESV # define CopFILESV(c) (CopFILE(c) ? GvSV(gv_fetchfile(CopFILE(c))) : Nullsv) #endif #ifndef CopFILEAV # define CopFILEAV(c) (CopFILE(c) ? GvAV(gv_fetchfile(CopFILE(c))) : Nullav) #endif #ifndef CopSTASHPV # define CopSTASHPV(c) ((c)->cop_stashpv) #endif #ifndef CopSTASHPV_set # define CopSTASHPV_set(c,pv) ((c)->cop_stashpv = ((pv) ? savepv(pv) : Nullch)) #endif #ifndef CopSTASH # define CopSTASH(c) (CopSTASHPV(c) ? gv_stashpv(CopSTASHPV(c),GV_ADD) : Nullhv) #endif #ifndef CopSTASH_set # define CopSTASH_set(c,hv) CopSTASHPV_set(c, (hv) ? HvNAME(hv) : Nullch) #endif #ifndef CopSTASH_eq # define CopSTASH_eq(c,hv) ((hv) && (CopSTASHPV(c) == HvNAME(hv) \ || (CopSTASHPV(c) && HvNAME(hv) \ && strEQ(CopSTASHPV(c), HvNAME(hv))))) #endif #else #ifndef CopFILEGV # define CopFILEGV(c) ((c)->cop_filegv) #endif #ifndef CopFILEGV_set # define CopFILEGV_set(c,gv) ((c)->cop_filegv = (GV*)SvREFCNT_inc(gv)) #endif #ifndef CopFILE_set # define CopFILE_set(c,pv) CopFILEGV_set((c), gv_fetchfile(pv)) #endif #ifndef CopFILESV # define CopFILESV(c) (CopFILEGV(c) ? GvSV(CopFILEGV(c)) : Nullsv) #endif #ifndef CopFILEAV # define CopFILEAV(c) (CopFILEGV(c) ? GvAV(CopFILEGV(c)) : Nullav) #endif #ifndef CopFILE # define CopFILE(c) (CopFILESV(c) ? SvPVX(CopFILESV(c)) : Nullch) #endif #ifndef CopSTASH # define CopSTASH(c) ((c)->cop_stash) #endif #ifndef CopSTASH_set # define CopSTASH_set(c,hv) ((c)->cop_stash = (hv)) #endif #ifndef CopSTASHPV # define CopSTASHPV(c) (CopSTASH(c) ? HvNAME(CopSTASH(c)) : Nullch) #endif #ifndef CopSTASHPV_set # define CopSTASHPV_set(c,pv) CopSTASH_set((c), gv_stashpv(pv,GV_ADD)) #endif #ifndef CopSTASH_eq # define CopSTASH_eq(c,hv) (CopSTASH(c) == (hv)) #endif #endif /* USE_ITHREADS */ #ifndef IN_PERL_COMPILETIME # define IN_PERL_COMPILETIME (PL_curcop == &PL_compiling) #endif #ifndef IN_LOCALE_RUNTIME # define IN_LOCALE_RUNTIME (PL_curcop->op_private & HINT_LOCALE) #endif #ifndef IN_LOCALE_COMPILETIME # define IN_LOCALE_COMPILETIME (PL_hints & HINT_LOCALE) #endif #ifndef IN_LOCALE # define IN_LOCALE (IN_PERL_COMPILETIME ? IN_LOCALE_COMPILETIME : IN_LOCALE_RUNTIME) #endif #ifndef IS_NUMBER_IN_UV # define IS_NUMBER_IN_UV 0x01 #endif #ifndef IS_NUMBER_GREATER_THAN_UV_MAX # define IS_NUMBER_GREATER_THAN_UV_MAX 0x02 #endif #ifndef IS_NUMBER_NOT_INT # define IS_NUMBER_NOT_INT 0x04 #endif #ifndef IS_NUMBER_NEG # define IS_NUMBER_NEG 0x08 #endif #ifndef IS_NUMBER_INFINITY # define IS_NUMBER_INFINITY 0x10 #endif #ifndef IS_NUMBER_NAN # define IS_NUMBER_NAN 0x20 #endif #ifndef GROK_NUMERIC_RADIX # define GROK_NUMERIC_RADIX(sp, send) grok_numeric_radix(sp, send) #endif #ifndef PERL_SCAN_GREATER_THAN_UV_MAX # define PERL_SCAN_GREATER_THAN_UV_MAX 0x02 #endif #ifndef PERL_SCAN_SILENT_ILLDIGIT # define PERL_SCAN_SILENT_ILLDIGIT 0x04 #endif #ifndef PERL_SCAN_ALLOW_UNDERSCORES # define PERL_SCAN_ALLOW_UNDERSCORES 0x01 #endif #ifndef PERL_SCAN_DISALLOW_PREFIX # define PERL_SCAN_DISALLOW_PREFIX 0x02 #endif #ifndef grok_numeric_radix #if defined(NEED_grok_numeric_radix) static bool DPPP_(my_grok_numeric_radix)(pTHX_ const char ** sp, const char * send); static #else extern bool DPPP_(my_grok_numeric_radix)(pTHX_ const char ** sp, const char * send); #endif #ifdef grok_numeric_radix # undef grok_numeric_radix #endif #define grok_numeric_radix(a,b) DPPP_(my_grok_numeric_radix)(aTHX_ a,b) #define Perl_grok_numeric_radix DPPP_(my_grok_numeric_radix) #if defined(NEED_grok_numeric_radix) || defined(NEED_grok_numeric_radix_GLOBAL) bool DPPP_(my_grok_numeric_radix)(pTHX_ const char **sp, const char *send) { #ifdef USE_LOCALE_NUMERIC #ifdef PL_numeric_radix_sv if (PL_numeric_radix_sv && IN_LOCALE) { STRLEN len; char* radix = SvPV(PL_numeric_radix_sv, len); if (*sp + len <= send && memEQ(*sp, radix, len)) { *sp += len; return TRUE; } } #else /* older perls don't have PL_numeric_radix_sv so the radix * must manually be requested from locale.h */ #include dTHR; /* needed for older threaded perls */ struct lconv *lc = localeconv(); char *radix = lc->decimal_point; if (radix && IN_LOCALE) { STRLEN len = strlen(radix); if (*sp + len <= send && memEQ(*sp, radix, len)) { *sp += len; return TRUE; } } #endif #endif /* USE_LOCALE_NUMERIC */ /* always try "." if numeric radix didn't match because * we may have data from different locales mixed */ if (*sp < send && **sp == '.') { ++*sp; return TRUE; } return FALSE; } #endif #endif #ifndef grok_number #if defined(NEED_grok_number) static int DPPP_(my_grok_number)(pTHX_ const char * pv, STRLEN len, UV * valuep); static #else extern int DPPP_(my_grok_number)(pTHX_ const char * pv, STRLEN len, UV * valuep); #endif #ifdef grok_number # undef grok_number #endif #define grok_number(a,b,c) DPPP_(my_grok_number)(aTHX_ a,b,c) #define Perl_grok_number DPPP_(my_grok_number) #if defined(NEED_grok_number) || defined(NEED_grok_number_GLOBAL) int DPPP_(my_grok_number)(pTHX_ const char *pv, STRLEN len, UV *valuep) { const char *s = pv; const char *send = pv + len; const UV max_div_10 = UV_MAX / 10; const char max_mod_10 = UV_MAX % 10; int numtype = 0; int sawinf = 0; int sawnan = 0; while (s < send && isSPACE(*s)) s++; if (s == send) { return 0; } else if (*s == '-') { s++; numtype = IS_NUMBER_NEG; } else if (*s == '+') s++; if (s == send) return 0; /* next must be digit or the radix separator or beginning of infinity */ if (isDIGIT(*s)) { /* UVs are at least 32 bits, so the first 9 decimal digits cannot overflow. */ UV value = *s - '0'; /* This construction seems to be more optimiser friendly. (without it gcc does the isDIGIT test and the *s - '0' separately) With it gcc on arm is managing 6 instructions (6 cycles) per digit. In theory the optimiser could deduce how far to unroll the loop before checking for overflow. */ if (++s < send) { int digit = *s - '0'; if (digit >= 0 && digit <= 9) { value = value * 10 + digit; if (++s < send) { digit = *s - '0'; if (digit >= 0 && digit <= 9) { value = value * 10 + digit; if (++s < send) { digit = *s - '0'; if (digit >= 0 && digit <= 9) { value = value * 10 + digit; if (++s < send) { digit = *s - '0'; if (digit >= 0 && digit <= 9) { value = value * 10 + digit; if (++s < send) { digit = *s - '0'; if (digit >= 0 && digit <= 9) { value = value * 10 + digit; if (++s < send) { digit = *s - '0'; if (digit >= 0 && digit <= 9) { value = value * 10 + digit; if (++s < send) { digit = *s - '0'; if (digit >= 0 && digit <= 9) { value = value * 10 + digit; if (++s < send) { digit = *s - '0'; if (digit >= 0 && digit <= 9) { value = value * 10 + digit; if (++s < send) { /* Now got 9 digits, so need to check each time for overflow. */ digit = *s - '0'; while (digit >= 0 && digit <= 9 && (value < max_div_10 || (value == max_div_10 && digit <= max_mod_10))) { value = value * 10 + digit; if (++s < send) digit = *s - '0'; else break; } if (digit >= 0 && digit <= 9 && (s < send)) { /* value overflowed. skip the remaining digits, don't worry about setting *valuep. */ do { s++; } while (s < send && isDIGIT(*s)); numtype |= IS_NUMBER_GREATER_THAN_UV_MAX; goto skip_value; } } } } } } } } } } } } } } } } } } numtype |= IS_NUMBER_IN_UV; if (valuep) *valuep = value; skip_value: if (GROK_NUMERIC_RADIX(&s, send)) { numtype |= IS_NUMBER_NOT_INT; while (s < send && isDIGIT(*s)) /* optional digits after the radix */ s++; } } else if (GROK_NUMERIC_RADIX(&s, send)) { numtype |= IS_NUMBER_NOT_INT | IS_NUMBER_IN_UV; /* valuep assigned below */ /* no digits before the radix means we need digits after it */ if (s < send && isDIGIT(*s)) { do { s++; } while (s < send && isDIGIT(*s)); if (valuep) { /* integer approximation is valid - it's 0. */ *valuep = 0; } } else return 0; } else if (*s == 'I' || *s == 'i') { s++; if (s == send || (*s != 'N' && *s != 'n')) return 0; s++; if (s == send || (*s != 'F' && *s != 'f')) return 0; s++; if (s < send && (*s == 'I' || *s == 'i')) { s++; if (s == send || (*s != 'N' && *s != 'n')) return 0; s++; if (s == send || (*s != 'I' && *s != 'i')) return 0; s++; if (s == send || (*s != 'T' && *s != 't')) return 0; s++; if (s == send || (*s != 'Y' && *s != 'y')) return 0; s++; } sawinf = 1; } else if (*s == 'N' || *s == 'n') { /* XXX TODO: There are signaling NaNs and quiet NaNs. */ s++; if (s == send || (*s != 'A' && *s != 'a')) return 0; s++; if (s == send || (*s != 'N' && *s != 'n')) return 0; s++; sawnan = 1; } else return 0; if (sawinf) { numtype &= IS_NUMBER_NEG; /* Keep track of sign */ numtype |= IS_NUMBER_INFINITY | IS_NUMBER_NOT_INT; } else if (sawnan) { numtype &= IS_NUMBER_NEG; /* Keep track of sign */ numtype |= IS_NUMBER_NAN | IS_NUMBER_NOT_INT; } else if (s < send) { /* we can have an optional exponent part */ if (*s == 'e' || *s == 'E') { /* The only flag we keep is sign. Blow away any "it's UV" */ numtype &= IS_NUMBER_NEG; numtype |= IS_NUMBER_NOT_INT; s++; if (s < send && (*s == '-' || *s == '+')) s++; if (s < send && isDIGIT(*s)) { do { s++; } while (s < send && isDIGIT(*s)); } else return 0; } } while (s < send && isSPACE(*s)) s++; if (s >= send) return numtype; if (len == 10 && memEQ(pv, "0 but true", 10)) { if (valuep) *valuep = 0; return IS_NUMBER_IN_UV; } return 0; } #endif #endif /* * The grok_* routines have been modified to use warn() instead of * Perl_warner(). Also, 'hexdigit' was the former name of PL_hexdigit, * which is why the stack variable has been renamed to 'xdigit'. */ #ifndef grok_bin #if defined(NEED_grok_bin) static UV DPPP_(my_grok_bin)(pTHX_ const char * start, STRLEN * len_p, I32 * flags, NV * result); static #else extern UV DPPP_(my_grok_bin)(pTHX_ const char * start, STRLEN * len_p, I32 * flags, NV * result); #endif #ifdef grok_bin # undef grok_bin #endif #define grok_bin(a,b,c,d) DPPP_(my_grok_bin)(aTHX_ a,b,c,d) #define Perl_grok_bin DPPP_(my_grok_bin) #if defined(NEED_grok_bin) || defined(NEED_grok_bin_GLOBAL) UV DPPP_(my_grok_bin)(pTHX_ const char *start, STRLEN *len_p, I32 *flags, NV *result) { const char *s = start; STRLEN len = *len_p; UV value = 0; NV value_nv = 0; const UV max_div_2 = UV_MAX / 2; bool allow_underscores = *flags & PERL_SCAN_ALLOW_UNDERSCORES; bool overflowed = FALSE; if (!(*flags & PERL_SCAN_DISALLOW_PREFIX)) { /* strip off leading b or 0b. for compatibility silently suffer "b" and "0b" as valid binary numbers. */ if (len >= 1) { if (s[0] == 'b') { s++; len--; } else if (len >= 2 && s[0] == '0' && s[1] == 'b') { s+=2; len-=2; } } } for (; len-- && *s; s++) { char bit = *s; if (bit == '0' || bit == '1') { /* Write it in this wonky order with a goto to attempt to get the compiler to make the common case integer-only loop pretty tight. With gcc seems to be much straighter code than old scan_bin. */ redo: if (!overflowed) { if (value <= max_div_2) { value = (value << 1) | (bit - '0'); continue; } /* Bah. We're just overflowed. */ warn("Integer overflow in binary number"); overflowed = TRUE; value_nv = (NV) value; } value_nv *= 2.0; /* If an NV has not enough bits in its mantissa to * represent a UV this summing of small low-order numbers * is a waste of time (because the NV cannot preserve * the low-order bits anyway): we could just remember when * did we overflow and in the end just multiply value_nv by the * right amount. */ value_nv += (NV)(bit - '0'); continue; } if (bit == '_' && len && allow_underscores && (bit = s[1]) && (bit == '0' || bit == '1')) { --len; ++s; goto redo; } if (!(*flags & PERL_SCAN_SILENT_ILLDIGIT)) warn("Illegal binary digit '%c' ignored", *s); break; } if ( ( overflowed && value_nv > 4294967295.0) #if UVSIZE > 4 || (!overflowed && value > 0xffffffff ) #endif ) { warn("Binary number > 0b11111111111111111111111111111111 non-portable"); } *len_p = s - start; if (!overflowed) { *flags = 0; return value; } *flags = PERL_SCAN_GREATER_THAN_UV_MAX; if (result) *result = value_nv; return UV_MAX; } #endif #endif #ifndef grok_hex #if defined(NEED_grok_hex) static UV DPPP_(my_grok_hex)(pTHX_ const char * start, STRLEN * len_p, I32 * flags, NV * result); static #else extern UV DPPP_(my_grok_hex)(pTHX_ const char * start, STRLEN * len_p, I32 * flags, NV * result); #endif #ifdef grok_hex # undef grok_hex #endif #define grok_hex(a,b,c,d) DPPP_(my_grok_hex)(aTHX_ a,b,c,d) #define Perl_grok_hex DPPP_(my_grok_hex) #if defined(NEED_grok_hex) || defined(NEED_grok_hex_GLOBAL) UV DPPP_(my_grok_hex)(pTHX_ const char *start, STRLEN *len_p, I32 *flags, NV *result) { const char *s = start; STRLEN len = *len_p; UV value = 0; NV value_nv = 0; const UV max_div_16 = UV_MAX / 16; bool allow_underscores = *flags & PERL_SCAN_ALLOW_UNDERSCORES; bool overflowed = FALSE; const char *xdigit; if (!(*flags & PERL_SCAN_DISALLOW_PREFIX)) { /* strip off leading x or 0x. for compatibility silently suffer "x" and "0x" as valid hex numbers. */ if (len >= 1) { if (s[0] == 'x') { s++; len--; } else if (len >= 2 && s[0] == '0' && s[1] == 'x') { s+=2; len-=2; } } } for (; len-- && *s; s++) { xdigit = strchr((char *) PL_hexdigit, *s); if (xdigit) { /* Write it in this wonky order with a goto to attempt to get the compiler to make the common case integer-only loop pretty tight. With gcc seems to be much straighter code than old scan_hex. */ redo: if (!overflowed) { if (value <= max_div_16) { value = (value << 4) | ((xdigit - PL_hexdigit) & 15); continue; } warn("Integer overflow in hexadecimal number"); overflowed = TRUE; value_nv = (NV) value; } value_nv *= 16.0; /* If an NV has not enough bits in its mantissa to * represent a UV this summing of small low-order numbers * is a waste of time (because the NV cannot preserve * the low-order bits anyway): we could just remember when * did we overflow and in the end just multiply value_nv by the * right amount of 16-tuples. */ value_nv += (NV)((xdigit - PL_hexdigit) & 15); continue; } if (*s == '_' && len && allow_underscores && s[1] && (xdigit = strchr((char *) PL_hexdigit, s[1]))) { --len; ++s; goto redo; } if (!(*flags & PERL_SCAN_SILENT_ILLDIGIT)) warn("Illegal hexadecimal digit '%c' ignored", *s); break; } if ( ( overflowed && value_nv > 4294967295.0) #if UVSIZE > 4 || (!overflowed && value > 0xffffffff ) #endif ) { warn("Hexadecimal number > 0xffffffff non-portable"); } *len_p = s - start; if (!overflowed) { *flags = 0; return value; } *flags = PERL_SCAN_GREATER_THAN_UV_MAX; if (result) *result = value_nv; return UV_MAX; } #endif #endif #ifndef grok_oct #if defined(NEED_grok_oct) static UV DPPP_(my_grok_oct)(pTHX_ const char * start, STRLEN * len_p, I32 * flags, NV * result); static #else extern UV DPPP_(my_grok_oct)(pTHX_ const char * start, STRLEN * len_p, I32 * flags, NV * result); #endif #ifdef grok_oct # undef grok_oct #endif #define grok_oct(a,b,c,d) DPPP_(my_grok_oct)(aTHX_ a,b,c,d) #define Perl_grok_oct DPPP_(my_grok_oct) #if defined(NEED_grok_oct) || defined(NEED_grok_oct_GLOBAL) UV DPPP_(my_grok_oct)(pTHX_ const char *start, STRLEN *len_p, I32 *flags, NV *result) { const char *s = start; STRLEN len = *len_p; UV value = 0; NV value_nv = 0; const UV max_div_8 = UV_MAX / 8; bool allow_underscores = *flags & PERL_SCAN_ALLOW_UNDERSCORES; bool overflowed = FALSE; for (; len-- && *s; s++) { /* gcc 2.95 optimiser not smart enough to figure that this subtraction out front allows slicker code. */ int digit = *s - '0'; if (digit >= 0 && digit <= 7) { /* Write it in this wonky order with a goto to attempt to get the compiler to make the common case integer-only loop pretty tight. */ redo: if (!overflowed) { if (value <= max_div_8) { value = (value << 3) | digit; continue; } /* Bah. We're just overflowed. */ warn("Integer overflow in octal number"); overflowed = TRUE; value_nv = (NV) value; } value_nv *= 8.0; /* If an NV has not enough bits in its mantissa to * represent a UV this summing of small low-order numbers * is a waste of time (because the NV cannot preserve * the low-order bits anyway): we could just remember when * did we overflow and in the end just multiply value_nv by the * right amount of 8-tuples. */ value_nv += (NV)digit; continue; } if (digit == ('_' - '0') && len && allow_underscores && (digit = s[1] - '0') && (digit >= 0 && digit <= 7)) { --len; ++s; goto redo; } /* Allow \octal to work the DWIM way (that is, stop scanning * as soon as non-octal characters are seen, complain only iff * someone seems to want to use the digits eight and nine). */ if (digit == 8 || digit == 9) { if (!(*flags & PERL_SCAN_SILENT_ILLDIGIT)) warn("Illegal octal digit '%c' ignored", *s); } break; } if ( ( overflowed && value_nv > 4294967295.0) #if UVSIZE > 4 || (!overflowed && value > 0xffffffff ) #endif ) { warn("Octal number > 037777777777 non-portable"); } *len_p = s - start; if (!overflowed) { *flags = 0; return value; } *flags = PERL_SCAN_GREATER_THAN_UV_MAX; if (result) *result = value_nv; return UV_MAX; } #endif #endif #if !defined(my_snprintf) #if defined(NEED_my_snprintf) static int DPPP_(my_my_snprintf)(char * buffer, const Size_t len, const char * format, ...); static #else extern int DPPP_(my_my_snprintf)(char * buffer, const Size_t len, const char * format, ...); #endif #define my_snprintf DPPP_(my_my_snprintf) #define Perl_my_snprintf DPPP_(my_my_snprintf) #if defined(NEED_my_snprintf) || defined(NEED_my_snprintf_GLOBAL) int DPPP_(my_my_snprintf)(char *buffer, const Size_t len, const char *format, ...) { dTHX; int retval; va_list ap; va_start(ap, format); #ifdef HAS_VSNPRINTF retval = vsnprintf(buffer, len, format, ap); #else retval = vsprintf(buffer, format, ap); #endif va_end(ap); if (retval < 0 || (len > 0 && (Size_t)retval >= len)) Perl_croak(aTHX_ "panic: my_snprintf buffer overflow"); return retval; } #endif #endif #if !defined(my_sprintf) #if defined(NEED_my_sprintf) static int DPPP_(my_my_sprintf)(char * buffer, const char * pat, ...); static #else extern int DPPP_(my_my_sprintf)(char * buffer, const char * pat, ...); #endif #define my_sprintf DPPP_(my_my_sprintf) #define Perl_my_sprintf DPPP_(my_my_sprintf) #if defined(NEED_my_sprintf) || defined(NEED_my_sprintf_GLOBAL) int DPPP_(my_my_sprintf)(char *buffer, const char* pat, ...) { va_list args; va_start(args, pat); vsprintf(buffer, pat, args); va_end(args); return strlen(buffer); } #endif #endif #ifdef NO_XSLOCKS # ifdef dJMPENV # define dXCPT dJMPENV; int rEtV = 0 # define XCPT_TRY_START JMPENV_PUSH(rEtV); if (rEtV == 0) # define XCPT_TRY_END JMPENV_POP; # define XCPT_CATCH if (rEtV != 0) # define XCPT_RETHROW JMPENV_JUMP(rEtV) # else # define dXCPT Sigjmp_buf oldTOP; int rEtV = 0 # define XCPT_TRY_START Copy(top_env, oldTOP, 1, Sigjmp_buf); rEtV = Sigsetjmp(top_env, 1); if (rEtV == 0) # define XCPT_TRY_END Copy(oldTOP, top_env, 1, Sigjmp_buf); # define XCPT_CATCH if (rEtV != 0) # define XCPT_RETHROW Siglongjmp(top_env, rEtV) # endif #endif #if !defined(my_strlcat) #if defined(NEED_my_strlcat) static Size_t DPPP_(my_my_strlcat)(char * dst, const char * src, Size_t size); static #else extern Size_t DPPP_(my_my_strlcat)(char * dst, const char * src, Size_t size); #endif #define my_strlcat DPPP_(my_my_strlcat) #define Perl_my_strlcat DPPP_(my_my_strlcat) #if defined(NEED_my_strlcat) || defined(NEED_my_strlcat_GLOBAL) Size_t DPPP_(my_my_strlcat)(char *dst, const char *src, Size_t size) { Size_t used, length, copy; used = strlen(dst); length = strlen(src); if (size > 0 && used < size - 1) { copy = (length >= size - used) ? size - used - 1 : length; memcpy(dst + used, src, copy); dst[used + copy] = '\0'; } return used + length; } #endif #endif #if !defined(my_strlcpy) #if defined(NEED_my_strlcpy) static Size_t DPPP_(my_my_strlcpy)(char * dst, const char * src, Size_t size); static #else extern Size_t DPPP_(my_my_strlcpy)(char * dst, const char * src, Size_t size); #endif #define my_strlcpy DPPP_(my_my_strlcpy) #define Perl_my_strlcpy DPPP_(my_my_strlcpy) #if defined(NEED_my_strlcpy) || defined(NEED_my_strlcpy_GLOBAL) Size_t DPPP_(my_my_strlcpy)(char *dst, const char *src, Size_t size) { Size_t length, copy; length = strlen(src); if (size > 0) { copy = (length >= size) ? size - 1 : length; memcpy(dst, src, copy); dst[copy] = '\0'; } return length; } #endif #endif #ifndef PERL_PV_ESCAPE_QUOTE # define PERL_PV_ESCAPE_QUOTE 0x0001 #endif #ifndef PERL_PV_PRETTY_QUOTE # define PERL_PV_PRETTY_QUOTE PERL_PV_ESCAPE_QUOTE #endif #ifndef PERL_PV_PRETTY_ELLIPSES # define PERL_PV_PRETTY_ELLIPSES 0x0002 #endif #ifndef PERL_PV_PRETTY_LTGT # define PERL_PV_PRETTY_LTGT 0x0004 #endif #ifndef PERL_PV_ESCAPE_FIRSTCHAR # define PERL_PV_ESCAPE_FIRSTCHAR 0x0008 #endif #ifndef PERL_PV_ESCAPE_UNI # define PERL_PV_ESCAPE_UNI 0x0100 #endif #ifndef PERL_PV_ESCAPE_UNI_DETECT # define PERL_PV_ESCAPE_UNI_DETECT 0x0200 #endif #ifndef PERL_PV_ESCAPE_ALL # define PERL_PV_ESCAPE_ALL 0x1000 #endif #ifndef PERL_PV_ESCAPE_NOBACKSLASH # define PERL_PV_ESCAPE_NOBACKSLASH 0x2000 #endif #ifndef PERL_PV_ESCAPE_NOCLEAR # define PERL_PV_ESCAPE_NOCLEAR 0x4000 #endif #ifndef PERL_PV_ESCAPE_RE # define PERL_PV_ESCAPE_RE 0x8000 #endif #ifndef PERL_PV_PRETTY_NOCLEAR # define PERL_PV_PRETTY_NOCLEAR PERL_PV_ESCAPE_NOCLEAR #endif #ifndef PERL_PV_PRETTY_DUMP # define PERL_PV_PRETTY_DUMP PERL_PV_PRETTY_ELLIPSES|PERL_PV_PRETTY_QUOTE #endif #ifndef PERL_PV_PRETTY_REGPROP # define PERL_PV_PRETTY_REGPROP PERL_PV_PRETTY_ELLIPSES|PERL_PV_PRETTY_LTGT|PERL_PV_ESCAPE_RE #endif /* Hint: pv_escape * Note that unicode functionality is only backported to * those perl versions that support it. For older perl * versions, the implementation will fall back to bytes. */ #ifndef pv_escape #if defined(NEED_pv_escape) static char * DPPP_(my_pv_escape)(pTHX_ SV * dsv, char const * const str, const STRLEN count, const STRLEN max, STRLEN * const escaped, const U32 flags); static #else extern char * DPPP_(my_pv_escape)(pTHX_ SV * dsv, char const * const str, const STRLEN count, const STRLEN max, STRLEN * const escaped, const U32 flags); #endif #ifdef pv_escape # undef pv_escape #endif #define pv_escape(a,b,c,d,e,f) DPPP_(my_pv_escape)(aTHX_ a,b,c,d,e,f) #define Perl_pv_escape DPPP_(my_pv_escape) #if defined(NEED_pv_escape) || defined(NEED_pv_escape_GLOBAL) char * DPPP_(my_pv_escape)(pTHX_ SV *dsv, char const * const str, const STRLEN count, const STRLEN max, STRLEN * const escaped, const U32 flags) { const char esc = flags & PERL_PV_ESCAPE_RE ? '%' : '\\'; const char dq = flags & PERL_PV_ESCAPE_QUOTE ? '"' : esc; char octbuf[32] = "%123456789ABCDF"; STRLEN wrote = 0; STRLEN chsize = 0; STRLEN readsize = 1; #if defined(is_utf8_string) && defined(utf8_to_uvchr) bool isuni = flags & PERL_PV_ESCAPE_UNI ? 1 : 0; #endif const char *pv = str; const char * const end = pv + count; octbuf[0] = esc; if (!(flags & PERL_PV_ESCAPE_NOCLEAR)) sv_setpvs(dsv, ""); #if defined(is_utf8_string) && defined(utf8_to_uvchr) if ((flags & PERL_PV_ESCAPE_UNI_DETECT) && is_utf8_string((U8*)pv, count)) isuni = 1; #endif for (; pv < end && (!max || wrote < max) ; pv += readsize) { const UV u = #if defined(is_utf8_string) && defined(utf8_to_uvchr) isuni ? utf8_to_uvchr((U8*)pv, &readsize) : #endif (U8)*pv; const U8 c = (U8)u & 0xFF; if (u > 255 || (flags & PERL_PV_ESCAPE_ALL)) { if (flags & PERL_PV_ESCAPE_FIRSTCHAR) chsize = my_snprintf(octbuf, sizeof octbuf, "%"UVxf, u); else chsize = my_snprintf(octbuf, sizeof octbuf, "%cx{%"UVxf"}", esc, u); } else if (flags & PERL_PV_ESCAPE_NOBACKSLASH) { chsize = 1; } else { if (c == dq || c == esc || !isPRINT(c)) { chsize = 2; switch (c) { case '\\' : /* fallthrough */ case '%' : if (c == esc) octbuf[1] = esc; else chsize = 1; break; case '\v' : octbuf[1] = 'v'; break; case '\t' : octbuf[1] = 't'; break; case '\r' : octbuf[1] = 'r'; break; case '\n' : octbuf[1] = 'n'; break; case '\f' : octbuf[1] = 'f'; break; case '"' : if (dq == '"') octbuf[1] = '"'; else chsize = 1; break; default: chsize = my_snprintf(octbuf, sizeof octbuf, pv < end && isDIGIT((U8)*(pv+readsize)) ? "%c%03o" : "%c%o", esc, c); } } else { chsize = 1; } } if (max && wrote + chsize > max) { break; } else if (chsize > 1) { sv_catpvn(dsv, octbuf, chsize); wrote += chsize; } else { char tmp[2]; my_snprintf(tmp, sizeof tmp, "%c", c); sv_catpvn(dsv, tmp, 1); wrote++; } if (flags & PERL_PV_ESCAPE_FIRSTCHAR) break; } if (escaped != NULL) *escaped= pv - str; return SvPVX(dsv); } #endif #endif #ifndef pv_pretty #if defined(NEED_pv_pretty) static char * DPPP_(my_pv_pretty)(pTHX_ SV * dsv, char const * const str, const STRLEN count, const STRLEN max, char const * const start_color, char const * const end_color, const U32 flags); static #else extern char * DPPP_(my_pv_pretty)(pTHX_ SV * dsv, char const * const str, const STRLEN count, const STRLEN max, char const * const start_color, char const * const end_color, const U32 flags); #endif #ifdef pv_pretty # undef pv_pretty #endif #define pv_pretty(a,b,c,d,e,f,g) DPPP_(my_pv_pretty)(aTHX_ a,b,c,d,e,f,g) #define Perl_pv_pretty DPPP_(my_pv_pretty) #if defined(NEED_pv_pretty) || defined(NEED_pv_pretty_GLOBAL) char * DPPP_(my_pv_pretty)(pTHX_ SV *dsv, char const * const str, const STRLEN count, const STRLEN max, char const * const start_color, char const * const end_color, const U32 flags) { const U8 dq = (flags & PERL_PV_PRETTY_QUOTE) ? '"' : '%'; STRLEN escaped; if (!(flags & PERL_PV_PRETTY_NOCLEAR)) sv_setpvs(dsv, ""); if (dq == '"') sv_catpvs(dsv, "\""); else if (flags & PERL_PV_PRETTY_LTGT) sv_catpvs(dsv, "<"); if (start_color != NULL) sv_catpv(dsv, D_PPP_CONSTPV_ARG(start_color)); pv_escape(dsv, str, count, max, &escaped, flags | PERL_PV_ESCAPE_NOCLEAR); if (end_color != NULL) sv_catpv(dsv, D_PPP_CONSTPV_ARG(end_color)); if (dq == '"') sv_catpvs(dsv, "\""); else if (flags & PERL_PV_PRETTY_LTGT) sv_catpvs(dsv, ">"); if ((flags & PERL_PV_PRETTY_ELLIPSES) && escaped < count) sv_catpvs(dsv, "..."); return SvPVX(dsv); } #endif #endif #ifndef pv_display #if defined(NEED_pv_display) static char * DPPP_(my_pv_display)(pTHX_ SV * dsv, const char * pv, STRLEN cur, STRLEN len, STRLEN pvlim); static #else extern char * DPPP_(my_pv_display)(pTHX_ SV * dsv, const char * pv, STRLEN cur, STRLEN len, STRLEN pvlim); #endif #ifdef pv_display # undef pv_display #endif #define pv_display(a,b,c,d,e) DPPP_(my_pv_display)(aTHX_ a,b,c,d,e) #define Perl_pv_display DPPP_(my_pv_display) #if defined(NEED_pv_display) || defined(NEED_pv_display_GLOBAL) char * DPPP_(my_pv_display)(pTHX_ SV *dsv, const char *pv, STRLEN cur, STRLEN len, STRLEN pvlim) { pv_pretty(dsv, pv, cur, pvlim, NULL, NULL, PERL_PV_PRETTY_DUMP); if (len > cur && pv[cur] == '\0') sv_catpvs(dsv, "\\0"); return SvPVX(dsv); } #endif #endif #endif /* _P_P_PORTABILITY_H_ */ /* End of File ppport.h */ META.yml100644000767000024 5054712200352344 13640 0ustar00etherstaff000000000000Moose-2.1005--- abstract: 'A postmodern object system for Perl 5' author: - 'Moose is maintained by the Moose Cabal, along with the help of many contributors. See L and L for details.' build_requires: CPAN::Meta::Check: 0.007 Test::CheckDeps: 0.006 Test::Fatal: 0.001 Test::More: 0.94 Test::Requires: 0.05 configure_requires: Dist::CheckConflicts: 0.02 ExtUtils::MakeMaker: 6.30 dynamic_config: 0 generated_by: 'Dist::Zilla version 4.300035, CPAN::Meta::Converter version 2.131560' license: perl meta-spec: url: http://module-build.sourceforge.net/META-spec-v1.4.html version: 1.4 name: Moose no_index: directory: - benchmarks namespace: - Class::MOP::Mixin - Moose::Meta::Method::Accessor::Native - Moose::Meta::Mixin package: - Class::MOP::Class::Immutable::Trait - Class::MOP::Deprecated - Class::MOP::MiniTrait - Class::MOP::Mixin - Moose::Deprecated - Moose::Error::Util - Moose::Meta::Attribute::Native::Trait - Moose::Meta::Class::Immutable::Trait - Moose::Meta::Method::Accessor::Native - Moose::Meta::Object::Trait - Moose::Util::TypeConstraints::OptimizedConstraints - Moose::Util::TypeConstraints::Builtins provides: Class::MOP: file: lib/Class/MOP.pm version: 2.1005 Class::MOP::Attribute: file: lib/Class/MOP/Attribute.pm version: 2.1005 Class::MOP::Class: file: lib/Class/MOP/Class.pm version: 2.1005 Class::MOP::Instance: file: lib/Class/MOP/Instance.pm version: 2.1005 Class::MOP::Method: file: lib/Class/MOP/Method.pm version: 2.1005 Class::MOP::Method::Accessor: file: lib/Class/MOP/Method/Accessor.pm version: 2.1005 Class::MOP::Method::Constructor: file: lib/Class/MOP/Method/Constructor.pm version: 2.1005 Class::MOP::Method::Generated: file: lib/Class/MOP/Method/Generated.pm version: 2.1005 Class::MOP::Method::Inlined: file: lib/Class/MOP/Method/Inlined.pm version: 2.1005 Class::MOP::Method::Meta: file: lib/Class/MOP/Method/Meta.pm version: 2.1005 Class::MOP::Method::Overload: file: lib/Class/MOP/Method/Overload.pm version: 2.1005 Class::MOP::Method::Wrapped: file: lib/Class/MOP/Method/Wrapped.pm version: 2.1005 Class::MOP::Module: file: lib/Class/MOP/Module.pm version: 2.1005 Class::MOP::Object: file: lib/Class/MOP/Object.pm version: 2.1005 Class::MOP::Package: file: lib/Class/MOP/Package.pm version: 2.1005 Moose: file: lib/Moose.pm version: 2.1005 Moose::Cookbook: file: lib/Moose/Cookbook.pod version: 2.1005 Moose::Cookbook::Basics::BankAccount_MethodModifiersAndSubclassing: file: lib/Moose/Cookbook/Basics/BankAccount_MethodModifiersAndSubclassing.pod version: 2.1005 Moose::Cookbook::Basics::BinaryTree_AttributeFeatures: file: lib/Moose/Cookbook/Basics/BinaryTree_AttributeFeatures.pod version: 2.1005 Moose::Cookbook::Basics::BinaryTree_BuilderAndLazyBuild: file: lib/Moose/Cookbook/Basics/BinaryTree_BuilderAndLazyBuild.pod version: 2.1005 Moose::Cookbook::Basics::Company_Subtypes: file: lib/Moose/Cookbook/Basics/Company_Subtypes.pod version: 2.1005 Moose::Cookbook::Basics::DateTime_ExtendingNonMooseParent: file: lib/Moose/Cookbook/Basics/DateTime_ExtendingNonMooseParent.pod version: 2.1005 Moose::Cookbook::Basics::Genome_OverloadingSubtypesAndCoercion: file: lib/Moose/Cookbook/Basics/Genome_OverloadingSubtypesAndCoercion.pod version: 2.1005 Moose::Cookbook::Basics::HTTP_SubtypesAndCoercion: file: lib/Moose/Cookbook/Basics/HTTP_SubtypesAndCoercion.pod version: 2.1005 Moose::Cookbook::Basics::Immutable: file: lib/Moose/Cookbook/Basics/Immutable.pod version: 2.1005 Moose::Cookbook::Basics::Person_BUILDARGSAndBUILD: file: lib/Moose/Cookbook/Basics/Person_BUILDARGSAndBUILD.pod version: 2.1005 Moose::Cookbook::Basics::Point_AttributesAndSubclassing: file: lib/Moose/Cookbook/Basics/Point_AttributesAndSubclassing.pod version: 2.1005 Moose::Cookbook::Extending::Debugging_BaseClassRole: file: lib/Moose/Cookbook/Extending/Debugging_BaseClassRole.pod version: 2.1005 Moose::Cookbook::Extending::ExtensionOverview: file: lib/Moose/Cookbook/Extending/ExtensionOverview.pod version: 2.1005 Moose::Cookbook::Extending::Mooseish_MooseSugar: file: lib/Moose/Cookbook/Extending/Mooseish_MooseSugar.pod version: 2.1005 Moose::Cookbook::Legacy::Debugging_BaseClassReplacement: file: lib/Moose/Cookbook/Legacy/Debugging_BaseClassReplacement.pod version: 2.1005 Moose::Cookbook::Meta::GlobRef_InstanceMetaclass: file: lib/Moose/Cookbook/Meta/GlobRef_InstanceMetaclass.pod version: 2.1005 Moose::Cookbook::Meta::Labeled_AttributeMetaclass: file: lib/Moose/Cookbook/Legacy/Labeled_AttributeMetaclass.pod version: 2.1005 Moose::Cookbook::Meta::Labeled_AttributeTrait: file: lib/Moose/Cookbook/Meta/Labeled_AttributeTrait.pod version: 2.1005 Moose::Cookbook::Meta::PrivateOrPublic_MethodMetaclass: file: lib/Moose/Cookbook/Meta/PrivateOrPublic_MethodMetaclass.pod version: 2.1005 Moose::Cookbook::Meta::Table_ClassMetaclass: file: lib/Moose/Cookbook/Legacy/Table_ClassMetaclass.pod version: 2.1005 Moose::Cookbook::Meta::Table_MetaclassTrait: file: lib/Moose/Cookbook/Meta/Table_MetaclassTrait.pod version: 2.1005 Moose::Cookbook::Meta::WhyMeta: file: lib/Moose/Cookbook/Meta/WhyMeta.pod version: 2.1005 Moose::Cookbook::Roles::ApplicationToInstance: file: lib/Moose/Cookbook/Roles/ApplicationToInstance.pod version: 2.1005 Moose::Cookbook::Roles::Comparable_CodeReuse: file: lib/Moose/Cookbook/Roles/Comparable_CodeReuse.pod version: 2.1005 Moose::Cookbook::Snack::Keywords: file: lib/Moose/Cookbook/Snack/Keywords.pod version: 2.1005 Moose::Cookbook::Snack::Types: file: lib/Moose/Cookbook/Snack/Types.pod version: 2.1005 Moose::Cookbook::Style: file: lib/Moose/Cookbook/Style.pod version: 2.1005 Moose::Error::Confess: file: lib/Moose/Error/Confess.pm version: 2.1005 Moose::Error::Croak: file: lib/Moose/Error/Croak.pm version: 2.1005 Moose::Error::Default: file: lib/Moose/Error/Default.pm version: 2.1005 Moose::Exporter: file: lib/Moose/Exporter.pm version: 2.1005 Moose::Intro: file: lib/Moose/Intro.pod version: 2.1005 Moose::Manual: file: lib/Moose/Manual.pod version: 2.1005 Moose::Manual::Attributes: file: lib/Moose/Manual/Attributes.pod version: 2.1005 Moose::Manual::BestPractices: file: lib/Moose/Manual/BestPractices.pod version: 2.1005 Moose::Manual::Classes: file: lib/Moose/Manual/Classes.pod version: 2.1005 Moose::Manual::Concepts: file: lib/Moose/Manual/Concepts.pod version: 2.1005 Moose::Manual::Construction: file: lib/Moose/Manual/Construction.pod version: 2.1005 Moose::Manual::Contributing: file: lib/Moose/Manual/Contributing.pod version: 2.1005 Moose::Manual::Delegation: file: lib/Moose/Manual/Delegation.pod version: 2.1005 Moose::Manual::Delta: file: lib/Moose/Manual/Delta.pod version: 2.1005 Moose::Manual::FAQ: file: lib/Moose/Manual/FAQ.pod version: 2.1005 Moose::Manual::MOP: file: lib/Moose/Manual/MOP.pod version: 2.1005 Moose::Manual::MethodModifiers: file: lib/Moose/Manual/MethodModifiers.pod version: 2.1005 Moose::Manual::MooseX: file: lib/Moose/Manual/MooseX.pod version: 2.1005 Moose::Manual::Roles: file: lib/Moose/Manual/Roles.pod version: 2.1005 Moose::Manual::Types: file: lib/Moose/Manual/Types.pod version: 2.1005 Moose::Manual::Unsweetened: file: lib/Moose/Manual/Unsweetened.pod version: 2.1005 Moose::Meta::Attribute: file: lib/Moose/Meta/Attribute.pm version: 2.1005 Moose::Meta::Attribute::Custom::Moose: file: lib/Moose/Meta/Attribute.pm version: 2.1005 Moose::Meta::Attribute::Native: file: lib/Moose/Meta/Attribute/Native.pm version: 2.1005 Moose::Meta::Attribute::Native::Trait::Array: file: lib/Moose/Meta/Attribute/Native/Trait/Array.pm version: 2.1005 Moose::Meta::Attribute::Native::Trait::Bool: file: lib/Moose/Meta/Attribute/Native/Trait/Bool.pm version: 2.1005 Moose::Meta::Attribute::Native::Trait::Code: file: lib/Moose/Meta/Attribute/Native/Trait/Code.pm version: 2.1005 Moose::Meta::Attribute::Native::Trait::Counter: file: lib/Moose/Meta/Attribute/Native/Trait/Counter.pm version: 2.1005 Moose::Meta::Attribute::Native::Trait::Hash: file: lib/Moose/Meta/Attribute/Native/Trait/Hash.pm version: 2.1005 Moose::Meta::Attribute::Native::Trait::Number: file: lib/Moose/Meta/Attribute/Native/Trait/Number.pm version: 2.1005 Moose::Meta::Attribute::Native::Trait::String: file: lib/Moose/Meta/Attribute/Native/Trait/String.pm version: 2.1005 Moose::Meta::Class: file: lib/Moose/Meta/Class.pm version: 2.1005 Moose::Meta::Instance: file: lib/Moose/Meta/Instance.pm version: 2.1005 Moose::Meta::Method: file: lib/Moose/Meta/Method.pm version: 2.1005 Moose::Meta::Method::Accessor: file: lib/Moose/Meta/Method/Accessor.pm version: 2.1005 Moose::Meta::Method::Augmented: file: lib/Moose/Meta/Method/Augmented.pm version: 2.1005 Moose::Meta::Method::Constructor: file: lib/Moose/Meta/Method/Constructor.pm version: 2.1005 Moose::Meta::Method::Delegation: file: lib/Moose/Meta/Method/Delegation.pm version: 2.1005 Moose::Meta::Method::Destructor: file: lib/Moose/Meta/Method/Destructor.pm version: 2.1005 Moose::Meta::Method::Meta: file: lib/Moose/Meta/Method/Meta.pm version: 2.1005 Moose::Meta::Method::Overridden: file: lib/Moose/Meta/Method/Overridden.pm version: 2.1005 Moose::Meta::Role: file: lib/Moose/Meta/Role.pm version: 2.1005 Moose::Meta::Role::Application: file: lib/Moose/Meta/Role/Application.pm version: 2.1005 Moose::Meta::Role::Application::RoleSummation: file: lib/Moose/Meta/Role/Application/RoleSummation.pm version: 2.1005 Moose::Meta::Role::Application::ToClass: file: lib/Moose/Meta/Role/Application/ToClass.pm version: 2.1005 Moose::Meta::Role::Application::ToInstance: file: lib/Moose/Meta/Role/Application/ToInstance.pm version: 2.1005 Moose::Meta::Role::Application::ToRole: file: lib/Moose/Meta/Role/Application/ToRole.pm version: 2.1005 Moose::Meta::Role::Attribute: file: lib/Moose/Meta/Role/Attribute.pm version: 2.1005 Moose::Meta::Role::Composite: file: lib/Moose/Meta/Role/Composite.pm version: 2.1005 Moose::Meta::Role::Method: file: lib/Moose/Meta/Role/Method.pm version: 2.1005 Moose::Meta::Role::Method::Conflicting: file: lib/Moose/Meta/Role/Method/Conflicting.pm version: 2.1005 Moose::Meta::Role::Method::Required: file: lib/Moose/Meta/Role/Method/Required.pm version: 2.1005 Moose::Meta::TypeCoercion: file: lib/Moose/Meta/TypeCoercion.pm version: 2.1005 Moose::Meta::TypeCoercion::Union: file: lib/Moose/Meta/TypeCoercion/Union.pm version: 2.1005 Moose::Meta::TypeConstraint: file: lib/Moose/Meta/TypeConstraint.pm version: 2.1005 Moose::Meta::TypeConstraint::Class: file: lib/Moose/Meta/TypeConstraint/Class.pm version: 2.1005 Moose::Meta::TypeConstraint::DuckType: file: lib/Moose/Meta/TypeConstraint/DuckType.pm version: 2.1005 Moose::Meta::TypeConstraint::Enum: file: lib/Moose/Meta/TypeConstraint/Enum.pm version: 2.1005 Moose::Meta::TypeConstraint::Parameterizable: file: lib/Moose/Meta/TypeConstraint/Parameterizable.pm version: 2.1005 Moose::Meta::TypeConstraint::Parameterized: file: lib/Moose/Meta/TypeConstraint/Parameterized.pm version: 2.1005 Moose::Meta::TypeConstraint::Registry: file: lib/Moose/Meta/TypeConstraint/Registry.pm version: 2.1005 Moose::Meta::TypeConstraint::Role: file: lib/Moose/Meta/TypeConstraint/Role.pm version: 2.1005 Moose::Meta::TypeConstraint::Union: file: lib/Moose/Meta/TypeConstraint/Union.pm version: 2.1005 Moose::Object: file: lib/Moose/Object.pm version: 2.1005 Moose::Role: file: lib/Moose/Role.pm version: 2.1005 Moose::Spec::Role: file: lib/Moose/Spec/Role.pod version: 2.1005 Moose::Unsweetened: file: lib/Moose/Unsweetened.pod version: 2.1005 Moose::Util: file: lib/Moose/Util.pm version: 2.1005 Moose::Util::MetaRole: file: lib/Moose/Util/MetaRole.pm version: 2.1005 Moose::Util::TypeConstraints: file: lib/Moose/Util/TypeConstraints.pm version: 2.1005 Test::Moose: file: lib/Test/Moose.pm version: 2.1005 metaclass: file: lib/metaclass.pm version: 2.1005 oose: file: lib/oose.pm version: 2.1005 recommends: Devel::PartialDump: 0.14 requires: Carp: 1.22 Class::Load: 0.09 Class::Load::XS: 0.01 Data::OptList: 0.107 Devel::GlobalDestruction: 0 Dist::CheckConflicts: 0.02 Eval::Closure: 0.04 List::MoreUtils: 0.28 MRO::Compat: 0.05 Package::DeprecationManager: 0.11 Package::Stash: 0.32 Package::Stash::XS: 0.24 Params::Util: 1.00 Scalar::Util: 1.19 Sub::Exporter: 0.980 Sub::Name: 0.05 Task::Weaken: 0 Try::Tiny: 0.02 perl: v5.8.3 resources: bugtracker: https://rt.cpan.org/Dist/Display.html?Name=Moose repository: git://github.com/moose/moose.git version: 2.1005 x_Dist_Zilla: perl: version: 5.019002 plugins: - class: inc::RequireAuthorDeps name: '=inc::RequireAuthorDeps' version: ~ - class: inc::Clean name: '=inc::Clean' version: ~ - class: Dist::Zilla::Plugin::GatherDir name: GatherDir version: 4.300035 - class: Dist::Zilla::Plugin::PruneCruft name: PruneCruft version: 4.300035 - class: Dist::Zilla::Plugin::ManifestSkip name: ManifestSkip version: 4.300035 - class: Dist::Zilla::Plugin::MetaYAML name: MetaYAML version: 4.300035 - class: Dist::Zilla::Plugin::MetaJSON name: MetaJSON version: 4.300035 - class: Dist::Zilla::Plugin::License name: License version: 4.300035 - class: Dist::Zilla::Plugin::ExecDir name: ExecDir version: 4.300035 - class: Dist::Zilla::Plugin::ShareDir name: ShareDir version: 4.300035 - class: inc::MakeMaker name: '=inc::MakeMaker' version: ~ - class: Dist::Zilla::Plugin::Manifest name: Manifest version: 4.300035 - class: Dist::Zilla::Plugin::TestRelease name: TestRelease version: 4.300035 - class: Dist::Zilla::Plugin::UploadToCPAN name: UploadToCPAN version: 4.300035 - class: Dist::Zilla::Plugin::NextRelease name: NextRelease version: 4.300035 - class: Dist::Zilla::Plugin::PruneFiles name: PruneFiles version: 4.300035 - class: Dist::Zilla::Plugin::PkgVersion name: PkgVersion version: 4.300035 - class: Dist::Zilla::Plugin::MetaConfig name: MetaConfig version: 4.300035 - class: Dist::Zilla::Plugin::Authority name: Authority version: 1.006 - class: Dist::Zilla::Plugin::MetaResources name: MetaResources version: 4.300035 - class: Dist::Zilla::Plugin::MetaProvides::Package name: MetaProvides::Package version: 1.14000003 - class: Dist::Zilla::Plugin::MetaNoIndex name: MetaNoIndex version: 4.300035 - class: Dist::Zilla::Plugin::SurgicalPodWeaver name: SurgicalPodWeaver version: 0.0020 - class: inc::ExtractInlineTests name: '=inc::ExtractInlineTests' version: ~ - class: Dist::Zilla::Plugin::EOLTests name: EOLTests version: 0.02 - class: Dist::Zilla::Plugin::PodSyntaxTests name: PodSyntaxTests version: 4.300035 - class: Dist::Zilla::Plugin::NoTabsTests name: NoTabsTests version: 0.01 - class: Dist::Zilla::Plugin::RunExtraTests name: RunExtraTests version: 0.011 - class: Dist::Zilla::Plugin::Test::CheckDeps name: Test::CheckDeps version: 0.007 - class: Dist::Zilla::Plugin::Test::ChangesHasContent name: Test::ChangesHasContent version: 0.006 - class: Dist::Zilla::Plugin::CheckChangesHasContent name: CheckChangesHasContent version: 0.006 - class: Dist::Zilla::Plugin::Prereqs config: Dist::Zilla::Plugin::Prereqs: phase: runtime type: requires name: Prereqs version: 4.300035 - class: Dist::Zilla::Plugin::Prereqs config: Dist::Zilla::Plugin::Prereqs: phase: test type: requires name: TestRequires version: 4.300035 - class: Dist::Zilla::Plugin::Prereqs config: Dist::Zilla::Plugin::Prereqs: phase: develop type: requires name: DevelopRequires version: 4.300035 - class: Dist::Zilla::Plugin::Prereqs config: Dist::Zilla::Plugin::Prereqs: phase: runtime type: recommends name: RuntimeRecommends version: 4.300035 - class: Dist::Zilla::Plugin::Prereqs config: Dist::Zilla::Plugin::Prereqs: phase: develop type: conflicts name: DevelopConflicts version: 4.300035 - class: Dist::Zilla::Plugin::Conflicts name: Conflicts version: 0.10 - class: inc::CheckDelta name: '=inc::CheckDelta' version: ~ - class: inc::GitUpToDate name: '=inc::GitUpToDate' version: ~ - class: Dist::Zilla::Plugin::Git::Remote::Check name: Git::Remote::Check version: 0.1.2 - class: Dist::Zilla::Plugin::Git::CheckFor::CorrectBranch name: Git::CheckFor::CorrectBranch version: 0.006 - class: Dist::Zilla::Plugin::Git::Check name: Git::Check version: 2.014 - class: Dist::Zilla::Plugin::ConfirmRelease name: ConfirmRelease version: 4.300035 - class: Dist::Zilla::Plugin::Git::Commit name: Git::Commit version: 2.014 - class: Dist::Zilla::Plugin::Git::Tag name: Git::Tag version: 2.014 - class: Dist::Zilla::Plugin::Git::Push name: Git::Push version: 2.014 - class: Dist::Zilla::Plugin::FinderCode name: ':InstallModules' version: 4.300035 - class: Dist::Zilla::Plugin::FinderCode name: ':IncModules' version: 4.300035 - class: Dist::Zilla::Plugin::FinderCode name: ':TestFiles' version: 4.300035 - class: Dist::Zilla::Plugin::FinderCode name: ':ExecFiles' version: 4.300035 - class: Dist::Zilla::Plugin::FinderCode name: ':ShareFiles' version: 4.300035 - class: Dist::Zilla::Plugin::FinderCode name: ':MainModule' version: 4.300035 zilla: class: Dist::Zilla::Dist::Builder config: is_trial: 0 version: 4.300035 x_authority: cpan:STEVAN x_breaks: Catalyst: 5.80028 Devel::REPL: 1.003008 Fey: 0.36 Fey::ORM: 0.42 File::ChangeNotify: 0.15 KiokuDB: 0.51 Markdent: 0.16 Mason: 2.18 MooseX::ABC: 0.05 MooseX::Aliases: 0.08 MooseX::AlwaysCoerce: 0.13 MooseX::App: 1.18 MooseX::Attribute::Deflator: 2.1.7 MooseX::Attribute::Dependent: 1.1.0 MooseX::Attribute::Prototype: 0.10 MooseX::AttributeHelpers: 0.22 MooseX::AttributeIndexes: 1.0.0 MooseX::AttributeInflate: 0.02 MooseX::CascadeClearing: 0.03 MooseX::ClassAttribute: 0.26 MooseX::Constructor::AllErrors: 0.012 MooseX::FollowPBP: 0.02 MooseX::HasDefaults: 0.02 MooseX::InstanceTracking: 0.04 MooseX::LazyRequire: 0.06 MooseX::Meta::Attribute::Index: 0.04 MooseX::Meta::Attribute::Lvalue: 0.05 MooseX::MethodAttributes: 0.22 MooseX::NonMoose: 0.17 MooseX::POE: 0.214 MooseX::Params::Validate: 0.05 MooseX::PrivateSetters: 0.03 MooseX::Role::Cmd: 0.06 MooseX::Role::Parameterized: 0.23 MooseX::Role::WithOverloading: 0.07 MooseX::Scaffold: 0.05 MooseX::SemiAffordanceAccessor: 0.05 MooseX::SetOnce: 0.100473 MooseX::Singleton: 0.25 MooseX::SlurpyConstructor: 1.1 MooseX::StrictConstructor: 0.12 MooseX::Types: 0.19 MooseX::Types::Parameterizable: 0.05 MooseX::Types::Signal: 1.101930 MooseX::UndefTolerant: 0.11 PRANG: 0.14 Pod::Elemental: 0.093280 Reaction: 0.002003 Test::Able: 0.10 namespace::autoclean: 0.08 MANIFEST100644000767000024 6035112200352344 13512 0ustar00etherstaff000000000000Moose-2.1005Changes Changes.Class-MOP LICENSE MANIFEST META.json META.yml Makefile.PL README.md TODO author/convert-to-test-fatal author/extract-inline-tests author/find-dupe-test-numbers benchmarks/caf_vs_moose.pl benchmarks/cmop/all.yml benchmarks/cmop/foo.pl benchmarks/cmop/lib/Bench/Accessor.pm benchmarks/cmop/lib/Bench/Construct.pm benchmarks/cmop/lib/Bench/Run.pm benchmarks/cmop/lib/MOP/Immutable/Point.pm benchmarks/cmop/lib/MOP/Immutable/Point3D.pm benchmarks/cmop/lib/MOP/Installed/Point.pm benchmarks/cmop/lib/MOP/Installed/Point3D.pm benchmarks/cmop/lib/MOP/Point.pm benchmarks/cmop/lib/MOP/Point3D.pm benchmarks/cmop/lib/Plain/Point.pm benchmarks/cmop/lib/Plain/Point3D.pm benchmarks/cmop/loading-benchmark.pl benchmarks/cmop/profile.pl benchmarks/cmop/run_yml.pl benchmarks/immutable.pl benchmarks/lotsa-classes.pl benchmarks/method_modifiers.pl benchmarks/moose_bench.pl benchmarks/simple_class.pl benchmarks/simple_compile.pl benchmarks/simple_constructor.pl benchmarks/type_constraints.pl benchmarks/type_constraints2.pl bin/moose-outdated dist.ini doc/moosex-compile eg/class_browser.pl examples/ArrayBasedStorage.pod examples/AttributesWithHistory.pod examples/C3MethodDispatchOrder.pod examples/ClassEncapsulatedAttributes.pod examples/InsideOutClass.pod examples/InstanceCountingClass.pod examples/LazyClass.pod examples/Perl6Attribute.pod inc/CheckDelta.pm inc/Clean.pm inc/ExtractInlineTests.pm inc/GitUpToDate.pm inc/MMHelper.pm inc/MakeMaker.pm inc/MyInline.pm inc/RequireAuthorDeps.pm inc/TestRelease.pm lib/Class/MOP.pm lib/Class/MOP/Attribute.pm lib/Class/MOP/Class.pm lib/Class/MOP/Class/Immutable/Trait.pm lib/Class/MOP/Deprecated.pm lib/Class/MOP/Instance.pm lib/Class/MOP/Method.pm lib/Class/MOP/Method/Accessor.pm lib/Class/MOP/Method/Constructor.pm lib/Class/MOP/Method/Generated.pm lib/Class/MOP/Method/Inlined.pm lib/Class/MOP/Method/Meta.pm lib/Class/MOP/Method/Overload.pm lib/Class/MOP/Method/Wrapped.pm lib/Class/MOP/MiniTrait.pm lib/Class/MOP/Mixin.pm lib/Class/MOP/Mixin/AttributeCore.pm lib/Class/MOP/Mixin/HasAttributes.pm lib/Class/MOP/Mixin/HasMethods.pm lib/Class/MOP/Module.pm lib/Class/MOP/Object.pm lib/Class/MOP/Package.pm lib/Moose.pm lib/Moose/Conflicts.pm lib/Moose/Cookbook.pod lib/Moose/Cookbook/Basics/BankAccount_MethodModifiersAndSubclassing.pod lib/Moose/Cookbook/Basics/BinaryTree_AttributeFeatures.pod lib/Moose/Cookbook/Basics/BinaryTree_BuilderAndLazyBuild.pod lib/Moose/Cookbook/Basics/Company_Subtypes.pod lib/Moose/Cookbook/Basics/DateTime_ExtendingNonMooseParent.pod lib/Moose/Cookbook/Basics/Document_AugmentAndInner.pod lib/Moose/Cookbook/Basics/Genome_OverloadingSubtypesAndCoercion.pod lib/Moose/Cookbook/Basics/HTTP_SubtypesAndCoercion.pod lib/Moose/Cookbook/Basics/Immutable.pod lib/Moose/Cookbook/Basics/Person_BUILDARGSAndBUILD.pod lib/Moose/Cookbook/Basics/Point_AttributesAndSubclassing.pod lib/Moose/Cookbook/Extending/Debugging_BaseClassRole.pod lib/Moose/Cookbook/Extending/ExtensionOverview.pod lib/Moose/Cookbook/Extending/Mooseish_MooseSugar.pod lib/Moose/Cookbook/Legacy/Debugging_BaseClassReplacement.pod lib/Moose/Cookbook/Legacy/Labeled_AttributeMetaclass.pod lib/Moose/Cookbook/Legacy/Table_ClassMetaclass.pod lib/Moose/Cookbook/Meta/GlobRef_InstanceMetaclass.pod lib/Moose/Cookbook/Meta/Labeled_AttributeTrait.pod lib/Moose/Cookbook/Meta/PrivateOrPublic_MethodMetaclass.pod lib/Moose/Cookbook/Meta/Table_MetaclassTrait.pod lib/Moose/Cookbook/Meta/WhyMeta.pod lib/Moose/Cookbook/Roles/ApplicationToInstance.pod lib/Moose/Cookbook/Roles/Comparable_CodeReuse.pod lib/Moose/Cookbook/Roles/Restartable_AdvancedComposition.pod lib/Moose/Cookbook/Snack/Keywords.pod lib/Moose/Cookbook/Snack/Types.pod lib/Moose/Cookbook/Style.pod lib/Moose/Deprecated.pm lib/Moose/Error/Confess.pm lib/Moose/Error/Croak.pm lib/Moose/Error/Default.pm lib/Moose/Error/Util.pm lib/Moose/Exporter.pm lib/Moose/Intro.pod lib/Moose/Manual.pod lib/Moose/Manual/Attributes.pod lib/Moose/Manual/BestPractices.pod lib/Moose/Manual/Classes.pod lib/Moose/Manual/Concepts.pod lib/Moose/Manual/Construction.pod lib/Moose/Manual/Contributing.pod lib/Moose/Manual/Delegation.pod lib/Moose/Manual/Delta.pod lib/Moose/Manual/FAQ.pod lib/Moose/Manual/MOP.pod lib/Moose/Manual/MethodModifiers.pod lib/Moose/Manual/MooseX.pod lib/Moose/Manual/Roles.pod lib/Moose/Manual/Support.pod lib/Moose/Manual/Types.pod lib/Moose/Manual/Unsweetened.pod lib/Moose/Meta/Attribute.pm lib/Moose/Meta/Attribute/Native.pm lib/Moose/Meta/Attribute/Native/Trait.pm lib/Moose/Meta/Attribute/Native/Trait/Array.pm lib/Moose/Meta/Attribute/Native/Trait/Bool.pm lib/Moose/Meta/Attribute/Native/Trait/Code.pm lib/Moose/Meta/Attribute/Native/Trait/Counter.pm lib/Moose/Meta/Attribute/Native/Trait/Hash.pm lib/Moose/Meta/Attribute/Native/Trait/Number.pm lib/Moose/Meta/Attribute/Native/Trait/String.pm lib/Moose/Meta/Class.pm lib/Moose/Meta/Class/Immutable/Trait.pm lib/Moose/Meta/Instance.pm lib/Moose/Meta/Method.pm lib/Moose/Meta/Method/Accessor.pm lib/Moose/Meta/Method/Accessor/Native.pm lib/Moose/Meta/Method/Accessor/Native/Array.pm lib/Moose/Meta/Method/Accessor/Native/Array/Writer.pm lib/Moose/Meta/Method/Accessor/Native/Array/accessor.pm lib/Moose/Meta/Method/Accessor/Native/Array/clear.pm lib/Moose/Meta/Method/Accessor/Native/Array/count.pm lib/Moose/Meta/Method/Accessor/Native/Array/delete.pm lib/Moose/Meta/Method/Accessor/Native/Array/elements.pm lib/Moose/Meta/Method/Accessor/Native/Array/first.pm lib/Moose/Meta/Method/Accessor/Native/Array/first_index.pm lib/Moose/Meta/Method/Accessor/Native/Array/get.pm lib/Moose/Meta/Method/Accessor/Native/Array/grep.pm lib/Moose/Meta/Method/Accessor/Native/Array/insert.pm lib/Moose/Meta/Method/Accessor/Native/Array/is_empty.pm lib/Moose/Meta/Method/Accessor/Native/Array/join.pm lib/Moose/Meta/Method/Accessor/Native/Array/map.pm lib/Moose/Meta/Method/Accessor/Native/Array/natatime.pm lib/Moose/Meta/Method/Accessor/Native/Array/pop.pm lib/Moose/Meta/Method/Accessor/Native/Array/push.pm lib/Moose/Meta/Method/Accessor/Native/Array/reduce.pm lib/Moose/Meta/Method/Accessor/Native/Array/set.pm lib/Moose/Meta/Method/Accessor/Native/Array/shallow_clone.pm lib/Moose/Meta/Method/Accessor/Native/Array/shift.pm lib/Moose/Meta/Method/Accessor/Native/Array/shuffle.pm lib/Moose/Meta/Method/Accessor/Native/Array/sort.pm lib/Moose/Meta/Method/Accessor/Native/Array/sort_in_place.pm lib/Moose/Meta/Method/Accessor/Native/Array/splice.pm lib/Moose/Meta/Method/Accessor/Native/Array/uniq.pm lib/Moose/Meta/Method/Accessor/Native/Array/unshift.pm lib/Moose/Meta/Method/Accessor/Native/Bool/not.pm lib/Moose/Meta/Method/Accessor/Native/Bool/set.pm lib/Moose/Meta/Method/Accessor/Native/Bool/toggle.pm lib/Moose/Meta/Method/Accessor/Native/Bool/unset.pm lib/Moose/Meta/Method/Accessor/Native/Code/execute.pm lib/Moose/Meta/Method/Accessor/Native/Code/execute_method.pm lib/Moose/Meta/Method/Accessor/Native/Collection.pm lib/Moose/Meta/Method/Accessor/Native/Counter/Writer.pm lib/Moose/Meta/Method/Accessor/Native/Counter/dec.pm lib/Moose/Meta/Method/Accessor/Native/Counter/inc.pm lib/Moose/Meta/Method/Accessor/Native/Counter/reset.pm lib/Moose/Meta/Method/Accessor/Native/Counter/set.pm lib/Moose/Meta/Method/Accessor/Native/Hash.pm lib/Moose/Meta/Method/Accessor/Native/Hash/Writer.pm lib/Moose/Meta/Method/Accessor/Native/Hash/accessor.pm lib/Moose/Meta/Method/Accessor/Native/Hash/clear.pm lib/Moose/Meta/Method/Accessor/Native/Hash/count.pm lib/Moose/Meta/Method/Accessor/Native/Hash/defined.pm lib/Moose/Meta/Method/Accessor/Native/Hash/delete.pm lib/Moose/Meta/Method/Accessor/Native/Hash/elements.pm lib/Moose/Meta/Method/Accessor/Native/Hash/exists.pm lib/Moose/Meta/Method/Accessor/Native/Hash/get.pm lib/Moose/Meta/Method/Accessor/Native/Hash/is_empty.pm lib/Moose/Meta/Method/Accessor/Native/Hash/keys.pm lib/Moose/Meta/Method/Accessor/Native/Hash/kv.pm lib/Moose/Meta/Method/Accessor/Native/Hash/set.pm lib/Moose/Meta/Method/Accessor/Native/Hash/shallow_clone.pm lib/Moose/Meta/Method/Accessor/Native/Hash/values.pm lib/Moose/Meta/Method/Accessor/Native/Number/abs.pm lib/Moose/Meta/Method/Accessor/Native/Number/add.pm lib/Moose/Meta/Method/Accessor/Native/Number/div.pm lib/Moose/Meta/Method/Accessor/Native/Number/mod.pm lib/Moose/Meta/Method/Accessor/Native/Number/mul.pm lib/Moose/Meta/Method/Accessor/Native/Number/set.pm lib/Moose/Meta/Method/Accessor/Native/Number/sub.pm lib/Moose/Meta/Method/Accessor/Native/Reader.pm lib/Moose/Meta/Method/Accessor/Native/String/append.pm lib/Moose/Meta/Method/Accessor/Native/String/chomp.pm lib/Moose/Meta/Method/Accessor/Native/String/chop.pm lib/Moose/Meta/Method/Accessor/Native/String/clear.pm lib/Moose/Meta/Method/Accessor/Native/String/inc.pm lib/Moose/Meta/Method/Accessor/Native/String/length.pm lib/Moose/Meta/Method/Accessor/Native/String/match.pm lib/Moose/Meta/Method/Accessor/Native/String/prepend.pm lib/Moose/Meta/Method/Accessor/Native/String/replace.pm lib/Moose/Meta/Method/Accessor/Native/String/substr.pm lib/Moose/Meta/Method/Accessor/Native/Writer.pm lib/Moose/Meta/Method/Augmented.pm lib/Moose/Meta/Method/Constructor.pm lib/Moose/Meta/Method/Delegation.pm lib/Moose/Meta/Method/Destructor.pm lib/Moose/Meta/Method/Meta.pm lib/Moose/Meta/Method/Overridden.pm lib/Moose/Meta/Mixin/AttributeCore.pm lib/Moose/Meta/Object/Trait.pm lib/Moose/Meta/Role.pm lib/Moose/Meta/Role/Application.pm lib/Moose/Meta/Role/Application/RoleSummation.pm lib/Moose/Meta/Role/Application/ToClass.pm lib/Moose/Meta/Role/Application/ToInstance.pm lib/Moose/Meta/Role/Application/ToRole.pm lib/Moose/Meta/Role/Attribute.pm lib/Moose/Meta/Role/Composite.pm lib/Moose/Meta/Role/Method.pm lib/Moose/Meta/Role/Method/Conflicting.pm lib/Moose/Meta/Role/Method/Required.pm lib/Moose/Meta/TypeCoercion.pm lib/Moose/Meta/TypeCoercion/Union.pm lib/Moose/Meta/TypeConstraint.pm lib/Moose/Meta/TypeConstraint/Class.pm lib/Moose/Meta/TypeConstraint/DuckType.pm lib/Moose/Meta/TypeConstraint/Enum.pm lib/Moose/Meta/TypeConstraint/Parameterizable.pm lib/Moose/Meta/TypeConstraint/Parameterized.pm lib/Moose/Meta/TypeConstraint/Registry.pm lib/Moose/Meta/TypeConstraint/Role.pm lib/Moose/Meta/TypeConstraint/Union.pm lib/Moose/Object.pm lib/Moose/Role.pm lib/Moose/Spec/Role.pod lib/Moose/Unsweetened.pod lib/Moose/Util.pm lib/Moose/Util/MetaRole.pm lib/Moose/Util/TypeConstraints.pm lib/Moose/Util/TypeConstraints/Builtins.pm lib/Test/Moose.pm lib/metaclass.pm lib/oose.pm mop.c mop.h perltidyrc ppport.h t/00-check-deps.t t/000_load.t t/attributes/accessor_context.t t/attributes/accessor_inlining.t t/attributes/accessor_override_method.t t/attributes/accessor_overwrite_warning.t t/attributes/attr_dereference_test.t t/attributes/attribute_accessor_generation.t t/attributes/attribute_custom_metaclass.t t/attributes/attribute_delegation.t t/attributes/attribute_does.t t/attributes/attribute_inherited_slot_specs.t t/attributes/attribute_lazy_initializer.t t/attributes/attribute_names.t t/attributes/attribute_reader_generation.t t/attributes/attribute_required.t t/attributes/attribute_traits.t t/attributes/attribute_traits_n_meta.t t/attributes/attribute_traits_parameterized.t t/attributes/attribute_traits_registered.t t/attributes/attribute_triggers.t t/attributes/attribute_type_unions.t t/attributes/attribute_without_any_methods.t t/attributes/attribute_writer_generation.t t/attributes/bad_coerce.t t/attributes/chained_coercion.t t/attributes/clone_weak.t t/attributes/default_class_role_types.t t/attributes/default_undef.t t/attributes/delegation_and_modifiers.t t/attributes/delegation_arg_aliasing.t t/attributes/delegation_target_not_loaded.t t/attributes/illegal_options_for_inheritance.t t/attributes/inherit_lazy_build.t t/attributes/lazy_no_default.t t/attributes/method_generation_rules.t t/attributes/misc_attribute_coerce_lazy.t t/attributes/misc_attribute_tests.t t/attributes/more_attr_delegation.t t/attributes/no_init_arg.t t/attributes/no_slot_access.t t/attributes/non_alpha_attr_names.t t/attributes/numeric_defaults.t t/attributes/trigger_and_coerce.t t/basics/always_strict_warnings.t t/basics/basic_class_setup.t t/basics/buildargs.t t/basics/buildargs_warning.t t/basics/create.t t/basics/create_anon.t t/basics/deprecations.t t/basics/destruction.t t/basics/error_handling.t t/basics/global-destruction-helper.pl t/basics/global_destruction.t t/basics/import_unimport.t t/basics/inner_and_augment.t t/basics/load_into_main.t t/basics/method_modifier_with_regexp.t t/basics/methods.t t/basics/moose_object_does.t t/basics/moose_respects_type_constraints.t t/basics/override_and_foreign_classes.t t/basics/override_augment_inner_super.t t/basics/rebless.t t/basics/require_superclasses.t t/basics/super_and_override.t t/basics/super_warns_on_args.t t/basics/universal_methods_wrappable.t t/basics/wrapped_method_cxt_propagation.t t/bugs/DEMOLISHALL.t t/bugs/DEMOLISHALL_shortcutted.t t/bugs/DEMOLISH_eats_exceptions.t t/bugs/DEMOLISH_eats_mini.t t/bugs/DEMOLISH_fails_without_metaclass.t t/bugs/Moose_Object_error.t t/bugs/anon_method_metaclass.t t/bugs/application_metarole_compat.t t/bugs/apply_role_to_one_instance_only.t t/bugs/attribute_trait_parameters.t t/bugs/augment_recursion_bug.t t/bugs/coerce_without_coercion.t t/bugs/constructor_object_overload.t t/bugs/create_anon_recursion.t t/bugs/delete_sub_stash.t t/bugs/handles_foreign_class_bug.t t/bugs/immutable_metaclass_does_role.t t/bugs/immutable_n_default_x2.t t/bugs/inheriting_from_roles.t t/bugs/inline_reader_bug.t t/bugs/instance_application_role_args.t t/bugs/lazybuild_required_undef.t t/bugs/moose_exporter_false_circular_reference_rt_63818.t t/bugs/moose_octal_defaults.t t/bugs/native_trait_handles_bad_value.t t/bugs/reader_precedence_bug.t t/bugs/role_caller.t t/bugs/subclass_use_base_bug.t t/bugs/subtype_conflict_bug.t t/bugs/subtype_quote_bug.t t/bugs/super_recursion.t t/bugs/traits_with_exporter.t t/bugs/type_constraint_messages.t t/cmop/ArrayBasedStorage_test.t t/cmop/AttributesWithHistory_test.t t/cmop/BinaryTree_test.t t/cmop/C3MethodDispatchOrder_test.t t/cmop/ClassEncapsulatedAttributes_test.t t/cmop/Class_C3_compatibility.t t/cmop/InsideOutClass_test.t t/cmop/InstanceCountingClass_test.t t/cmop/LazyClass_test.t t/cmop/Perl6Attribute_test.t t/cmop/RT_27329_fix.t t/cmop/RT_39001_fix.t t/cmop/RT_41255.t t/cmop/add_attribute_alternate.t t/cmop/add_method_modifier.t t/cmop/advanced_methods.t t/cmop/anon_class.t t/cmop/anon_class_create_init.t t/cmop/anon_class_keep_alive.t t/cmop/anon_class_leak.t t/cmop/anon_class_removal.t t/cmop/anon_packages.t t/cmop/attribute.t t/cmop/attribute_duplication.t t/cmop/attribute_errors_and_edge_cases.t t/cmop/attribute_get_read_write.t t/cmop/attribute_initializer.t t/cmop/attribute_introspection.t t/cmop/attribute_non_alpha_name.t t/cmop/attributes.t t/cmop/basic.t t/cmop/before_after_dollar_under.t t/cmop/class_errors_and_edge_cases.t t/cmop/class_is_pristine.t t/cmop/class_precedence_list.t t/cmop/constant_codeinfo.t t/cmop/create_class.t t/cmop/custom_instance.t t/cmop/deprecated.t t/cmop/get_code_info.t t/cmop/immutable_custom_trait.t t/cmop/immutable_metaclass.t t/cmop/immutable_w_constructors.t t/cmop/immutable_w_custom_metaclass.t t/cmop/inline_and_dollar_at.t t/cmop/inline_structor.t t/cmop/insertion_order.t t/cmop/instance.t t/cmop/instance_inline.t t/cmop/instance_metaclass_incompat.t t/cmop/instance_metaclass_incompat_dyn.t t/cmop/lib/BinaryTree.pm t/cmop/lib/MyMetaClass.pm t/cmop/lib/MyMetaClass/Attribute.pm t/cmop/lib/MyMetaClass/Instance.pm t/cmop/lib/MyMetaClass/Method.pm t/cmop/lib/MyMetaClass/Random.pm t/cmop/lib/SyntaxError.pm t/cmop/load.t t/cmop/magic.t t/cmop/make_mutable.t t/cmop/meta_method.t t/cmop/meta_package.t t/cmop/meta_package_extension.t t/cmop/metaclass.t t/cmop/metaclass_incompatibility.t t/cmop/metaclass_incompatibility_dyn.t t/cmop/metaclass_inheritance.t t/cmop/metaclass_loads_classes.t t/cmop/metaclass_reinitialize.t t/cmop/method.t t/cmop/method_modifiers.t t/cmop/methods.t t/cmop/modify_parent_method.t t/cmop/new_and_clone_metaclasses.t t/cmop/null_stash.t t/cmop/numeric_defaults.t t/cmop/package_variables.t t/cmop/random_eval_bug.t t/cmop/rebless_instance.t t/cmop/rebless_instance_away.t t/cmop/rebless_overload.t t/cmop/rebless_with_extra_params.t t/cmop/scala_style_mixin_composition.t t/cmop/self_introspection.t t/cmop/subclasses.t t/cmop/subname.t t/cmop/universal_methods.t t/compat/composite_metaroles.t t/compat/extends_nonmoose_that_isa_moose_with_metarole.t t/compat/foreign_inheritence.t t/compat/module_refresh_compat.t t/compat/moose_respects_base.t t/examples/Child_Parent_attr_inherit.t t/examples/example1.t t/examples/example2.t t/examples/example_Moose_POOP.t t/examples/example_Protomoose.t t/examples/example_w_DCS.t t/examples/example_w_TestDeep.t t/examples/record_set_iterator.t t/immutable/apply_roles_to_immutable.t t/immutable/buildargs.t t/immutable/constructor_is_not_moose.t t/immutable/constructor_is_wrapped.t t/immutable/default_values.t t/immutable/definition_context.t t/immutable/immutable_constructor_error.t t/immutable/immutable_destroy.t t/immutable/immutable_meta_class.t t/immutable/immutable_metaclass_with_traits.t t/immutable/immutable_moose.t t/immutable/immutable_roundtrip.t t/immutable/immutable_trigger_from_constructor.t t/immutable/inline_close_over.t t/immutable/inline_fallbacks.t t/immutable/inlined_constructors_n_types.t t/immutable/multiple_demolish_inline.t t/lib/Bar.pm t/lib/Bar7/Meta/Trait.pm t/lib/Bar7/Meta/Trait2.pm t/lib/Foo.pm t/lib/Moose/Meta/Attribute/Custom/Bar.pm t/lib/Moose/Meta/Attribute/Custom/Foo.pm t/lib/Moose/Meta/Attribute/Custom/Trait/Bar.pm t/lib/Moose/Meta/Attribute/Custom/Trait/Foo.pm t/lib/MyExporter.pm t/lib/MyMetaclassRole.pm t/lib/MyMooseA.pm t/lib/MyMooseB.pm t/lib/MyMooseObject.pm t/lib/NoInlineAttribute.pm t/lib/Role/Child.pm t/lib/Role/Interface.pm t/lib/Role/Parent.pm t/metaclasses/create_anon_with_required_attr.t t/metaclasses/custom_attr_meta_as_role.t t/metaclasses/custom_attr_meta_with_roles.t t/metaclasses/custom_error_class.t t/metaclasses/easy_init_meta.t t/metaclasses/export_with_prototype.t t/metaclasses/exporter_also_with_trait.t t/metaclasses/exporter_meta_lookup.t t/metaclasses/goto_moose_import.t t/metaclasses/immutable_metaclass_compat_bug.t t/metaclasses/meta_name.t t/metaclasses/metaclass_compat.t t/metaclasses/metaclass_compat_no_fixing_bug.t t/metaclasses/metaclass_compat_role_conflicts.t t/metaclasses/metaclass_parameterized_traits.t t/metaclasses/metaclass_traits.t t/metaclasses/metarole.t t/metaclasses/metarole_combination.t t/metaclasses/metarole_on_anon.t t/metaclasses/metarole_w_metaclass_pm.t t/metaclasses/metaroles_of_metaroles.t t/metaclasses/moose_exporter.t t/metaclasses/moose_exporter_trait_aliases.t t/metaclasses/moose_for_meta.t t/metaclasses/moose_nonmoose_metatrait_init_order.t t/metaclasses/moose_nonmoose_moose_chain_init_meta.t t/metaclasses/moose_w_metaclass.t t/metaclasses/new_metaclass.t t/metaclasses/new_object_BUILD.t t/metaclasses/overloading.t t/metaclasses/reinitialize.t t/metaclasses/throw_error.t t/metaclasses/use_base_of_moose.t t/moose_util/apply_roles.t t/moose_util/create_alias.t t/moose_util/ensure_all_roles.t t/moose_util/method_mod_args.t t/moose_util/moose_util.t t/moose_util/moose_util_does_role.t t/moose_util/moose_util_search_class_by_role.t t/moose_util/resolve_alias.t t/moose_util/with_traits.t t/native_traits/array_coerce.t t/native_traits/array_from_role.t t/native_traits/array_subtypes.t t/native_traits/array_trigger.t t/native_traits/collection_with_roles.t t/native_traits/custom_instance.t t/native_traits/hash_coerce.t t/native_traits/hash_subtypes.t t/native_traits/hash_trigger.t t/native_traits/remove_attribute.t t/native_traits/shallow_clone.t t/native_traits/trait_array.t t/native_traits/trait_bool.t t/native_traits/trait_code.t t/native_traits/trait_counter.t t/native_traits/trait_hash.t t/native_traits/trait_number.t t/native_traits/trait_string.t t/recipes/basics_bankaccount_methodmodifiersandsubclassing.t t/recipes/basics_binarytree_attributefeatures.t t/recipes/basics_company_subtypes.t t/recipes/basics_datetime_extendingnonmooseparent.t t/recipes/basics_geonome_overloadingsubtypesandcoercion.t t/recipes/basics_http_subtypesandcoercion.t t/recipes/basics_point_attributesandsubclassing.t t/recipes/extending_debugging_baseclassrole.t t/recipes/extending_mooseish_moosesugar.t t/recipes/legacy_debugging_baseclassreplacement.t t/recipes/meta_globref_instancemetaclass.t t/recipes/meta_labeled_attributemetaclass.t t/recipes/meta_labeled_attributetrait.t t/recipes/meta_privateorpublic_methodmetaclass.t t/recipes/meta_table_metaclasstrait.t t/recipes/roles_applicationtoinstance.t t/recipes/roles_comparable_codereuse.t t/roles/anonymous_roles.t t/roles/application_toclass.t t/roles/apply_role.t t/roles/build.t t/roles/compose_overloading.t t/roles/conflict_many_methods.t t/roles/create_role.t t/roles/create_role_subclass.t t/roles/empty_method_modifiers_meta_bug.t t/roles/extending_role_attrs.t t/roles/free_anonymous_roles.t t/roles/imported_required_method.t t/roles/meta_role.t t/roles/method_aliasing_in_composition.t t/roles/method_exclusion_in_composition.t t/roles/method_modifiers.t t/roles/methods.t t/roles/more_alias_and_exclude.t t/roles/more_role_edge_cases.t t/roles/new_meta_role.t t/roles/overriding.t t/roles/reinitialize_anon_role.t t/roles/role.t t/roles/role_attr_application.t t/roles/role_attribute_conflict.t t/roles/role_attrs.t t/roles/role_compose_requires.t t/roles/role_composite.t t/roles/role_composite_exclusion.t t/roles/role_composition_attributes.t t/roles/role_composition_conflict_detection.t t/roles/role_composition_errors.t t/roles/role_composition_method_mods.t t/roles/role_composition_methods.t t/roles/role_composition_override.t t/roles/role_composition_req_methods.t t/roles/role_conflict_detection.t t/roles/role_conflict_edge_cases.t t/roles/role_consumers.t t/roles/role_exclusion.t t/roles/role_exclusion_and_alias_bug.t t/roles/role_for_combination.t t/roles/roles_and_method_cloning.t t/roles/roles_and_req_method_edge_cases.t t/roles/roles_applied_in_create.t t/roles/run_time_role_composition.t t/roles/runtime_roles_and_attrs.t t/roles/runtime_roles_and_nonmoose.t t/roles/runtime_roles_w_params.t t/roles/use_base_does.t t/test_moose/test_moose.t t/test_moose/test_moose_does_ok.t t/test_moose/test_moose_has_attribute_ok.t t/test_moose/test_moose_meta_ok.t t/test_moose/with_immutable.t t/test_moose/with_immutable_tb2.t t/todo_tests/exception_reflects_failed_constraint.t t/todo_tests/immutable_n_around.t t/todo_tests/moose_and_threads.t t/todo_tests/replacing_super_methods.t t/todo_tests/required_role_accessors.t t/todo_tests/role_attr_methods_original_package.t t/todo_tests/role_insertion_order.t t/todo_tests/various_role_features.t t/type_constraints/advanced_type_creation.t t/type_constraints/class_subtypes.t t/type_constraints/class_type_constraint.t t/type_constraints/coerced_parameterized_types.t t/type_constraints/container_type_coercion.t t/type_constraints/container_type_constraint.t t/type_constraints/custom_parameterized_types.t t/type_constraints/custom_type_errors.t t/type_constraints/define_type_twice_throws.t t/type_constraints/duck_type_handles.t t/type_constraints/duck_types.t t/type_constraints/enum.t t/type_constraints/inlining.t t/type_constraints/match_type_operator.t t/type_constraints/maybe_type_constraint.t t/type_constraints/misc_type_tests.t t/type_constraints/name_conflicts.t t/type_constraints/normalize_type_name.t t/type_constraints/parameterize_from.t t/type_constraints/role_type_constraint.t t/type_constraints/specio.t t/type_constraints/subtype_auto_vivify_parent.t t/type_constraints/subtyping_parameterized_types.t t/type_constraints/subtyping_union_types.t t/type_constraints/throw_error.t t/type_constraints/type_coersion_on_lazy_attributes.t t/type_constraints/type_names.t t/type_constraints/type_notation_parser.t t/type_constraints/types_and_undef.t t/type_constraints/union_is_a_type_of.t t/type_constraints/union_types.t t/type_constraints/union_types_and_coercions.t t/type_constraints/util_find_type_constraint.t t/type_constraints/util_more_type_coercion.t t/type_constraints/util_std_type_constraints.t t/type_constraints/util_type_coercion.t t/type_constraints/util_type_constraints.t t/type_constraints/util_type_constraints_export.t t/type_constraints/util_type_reloading.t xs/Attribute.xs xs/AttributeCore.xs xs/Class.xs xs/Generated.xs xs/HasAttributes.xs xs/HasMethods.xs xs/Inlined.xs xs/Instance.xs xs/MOP.xs xs/Method.xs xs/Moose.xs xs/Overload.xs xs/Package.xs xs/typemap xt/author/debugger-duck_type.t xt/author/memory_leaks.t xt/author/test-my-dependents.t xt/release/changes_has_content.t xt/release/eol.t xt/release/no-tabs.t xt/release/pod-coverage.t xt/release/pod-spell.t xt/release/pod-syntax.t README.md100644000767000024 35112200352344 13572 0ustar00etherstaff000000000000Moose-2.1005[![Build Status](https://travis-ci.org/moose/moose.png?branch=master,stable/2.08)](https://travis-ci.org/moose/moose) Moose ===== Moose is a postmodern object system for Perl 5. Moose on CPAN: [https://metacpan.org/release/Moose] xs000755000767000024 012200352344 12626 5ustar00etherstaff000000000000Moose-2.1005MOP.xs100644000767000024 75712200352344 13766 0ustar00etherstaff000000000000Moose-2.1005/xs#include "mop.h" MODULE = Class::MOP PACKAGE = Class::MOP PROTOTYPES: DISABLE # use prototype here to be compatible with get_code_info from Sub::Identify void get_code_info(coderef) SV *coderef PROTOTYPE: $ PREINIT: char *pkg = NULL; char *name = NULL; PPCODE: SvGETMAGIC(coderef); if (mop_get_code_info(coderef, &pkg, &name)) { EXTEND(SP, 2); mPUSHs(newSVpv(pkg, 0)); mPUSHs(newSVpv(name, 0)); } META.json100644000767000024 7546412200352344 14015 0ustar00etherstaff000000000000Moose-2.1005{ "abstract" : "A postmodern object system for Perl 5", "author" : [ "Moose is maintained by the Moose Cabal, along with the help of many contributors. See L and L for details." ], "dynamic_config" : 0, "generated_by" : "Dist::Zilla version 4.300035, CPAN::Meta::Converter version 2.131560", "license" : [ "perl_5" ], "meta-spec" : { "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec", "version" : "2" }, "name" : "Moose", "no_index" : { "directory" : [ "benchmarks" ], "namespace" : [ "Class::MOP::Mixin", "Moose::Meta::Method::Accessor::Native", "Moose::Meta::Mixin" ], "package" : [ "Class::MOP::Class::Immutable::Trait", "Class::MOP::Deprecated", "Class::MOP::MiniTrait", "Class::MOP::Mixin", "Moose::Deprecated", "Moose::Error::Util", "Moose::Meta::Attribute::Native::Trait", "Moose::Meta::Class::Immutable::Trait", "Moose::Meta::Method::Accessor::Native", "Moose::Meta::Object::Trait", "Moose::Util::TypeConstraints::OptimizedConstraints", "Moose::Util::TypeConstraints::Builtins" ] }, "prereqs" : { "configure" : { "requires" : { "Dist::CheckConflicts" : "0.02", "ExtUtils::MakeMaker" : "6.30" } }, "develop" : { "conflicts" : { "Dist::Zilla::Plugin::Conflicts" : "== 0.11" }, "requires" : { "Algorithm::C3" : "0", "DBM::Deep" : "0", "Data::Visitor" : "0", "DateTime" : "0", "DateTime::Calendar::Mayan" : "0", "DateTime::Format::MySQL" : "0", "Declare::Constraints::Simple" : "0", "ExtUtils::MakeMaker::Dist::Zilla::Develop" : "0", "File::Find::Rule" : "0", "HTTP::Headers" : "0", "IO::File" : "0", "IO::String" : "0", "Locale::US" : "0", "Module::Info" : "0", "Module::Refresh" : "0", "MooseX::NonMoose" : "0", "PadWalker" : "0", "Params::Coerce" : "0", "Regexp::Common" : "0", "SUPER" : "0", "Specio" : "0.07", "Test::Deep" : "0", "Test::DependentModules" : "0.13", "Test::Inline" : "0", "Test::Inline::Extract" : "0", "Test::LeakTrace" : "0", "Test::Memory::Cycle" : "0", "Test::Output" : "0", "Test::Pod" : "1.41", "Test::Spelling" : "0", "URI" : "0" } }, "runtime" : { "recommends" : { "Devel::PartialDump" : "0.14" }, "requires" : { "Carp" : "1.22", "Class::Load" : "0.09", "Class::Load::XS" : "0.01", "Data::OptList" : "0.107", "Devel::GlobalDestruction" : "0", "Dist::CheckConflicts" : "0.02", "Eval::Closure" : "0.04", "List::MoreUtils" : "0.28", "MRO::Compat" : "0.05", "Package::DeprecationManager" : "0.11", "Package::Stash" : "0.32", "Package::Stash::XS" : "0.24", "Params::Util" : "1.00", "Scalar::Util" : "1.19", "Sub::Exporter" : "0.980", "Sub::Name" : "0.05", "Task::Weaken" : "0", "Try::Tiny" : "0.02", "perl" : "v5.8.3" } }, "test" : { "requires" : { "CPAN::Meta::Check" : "0.007", "Test::CheckDeps" : "0.006", "Test::Fatal" : "0.001", "Test::More" : "0.94", "Test::Requires" : "0.05" } } }, "provides" : { "Class::MOP" : { "file" : "lib/Class/MOP.pm", "version" : "2.1005" }, "Class::MOP::Attribute" : { "file" : "lib/Class/MOP/Attribute.pm", "version" : "2.1005" }, "Class::MOP::Class" : { "file" : "lib/Class/MOP/Class.pm", "version" : "2.1005" }, "Class::MOP::Instance" : { "file" : "lib/Class/MOP/Instance.pm", "version" : "2.1005" }, "Class::MOP::Method" : { "file" : "lib/Class/MOP/Method.pm", "version" : "2.1005" }, "Class::MOP::Method::Accessor" : { "file" : "lib/Class/MOP/Method/Accessor.pm", "version" : "2.1005" }, "Class::MOP::Method::Constructor" : { "file" : "lib/Class/MOP/Method/Constructor.pm", "version" : "2.1005" }, "Class::MOP::Method::Generated" : { "file" : "lib/Class/MOP/Method/Generated.pm", "version" : "2.1005" }, "Class::MOP::Method::Inlined" : { "file" : "lib/Class/MOP/Method/Inlined.pm", "version" : "2.1005" }, "Class::MOP::Method::Meta" : { "file" : "lib/Class/MOP/Method/Meta.pm", "version" : "2.1005" }, "Class::MOP::Method::Overload" : { "file" : "lib/Class/MOP/Method/Overload.pm", "version" : "2.1005" }, "Class::MOP::Method::Wrapped" : { "file" : "lib/Class/MOP/Method/Wrapped.pm", "version" : "2.1005" }, "Class::MOP::Module" : { "file" : "lib/Class/MOP/Module.pm", "version" : "2.1005" }, "Class::MOP::Object" : { "file" : "lib/Class/MOP/Object.pm", "version" : "2.1005" }, "Class::MOP::Package" : { "file" : "lib/Class/MOP/Package.pm", "version" : "2.1005" }, "Moose" : { "file" : "lib/Moose.pm", "version" : "2.1005" }, "Moose::Cookbook" : { "file" : "lib/Moose/Cookbook.pod", "version" : "2.1005" }, "Moose::Cookbook::Basics::BankAccount_MethodModifiersAndSubclassing" : { "file" : "lib/Moose/Cookbook/Basics/BankAccount_MethodModifiersAndSubclassing.pod", "version" : "2.1005" }, "Moose::Cookbook::Basics::BinaryTree_AttributeFeatures" : { "file" : "lib/Moose/Cookbook/Basics/BinaryTree_AttributeFeatures.pod", "version" : "2.1005" }, "Moose::Cookbook::Basics::BinaryTree_BuilderAndLazyBuild" : { "file" : "lib/Moose/Cookbook/Basics/BinaryTree_BuilderAndLazyBuild.pod", "version" : "2.1005" }, "Moose::Cookbook::Basics::Company_Subtypes" : { "file" : "lib/Moose/Cookbook/Basics/Company_Subtypes.pod", "version" : "2.1005" }, "Moose::Cookbook::Basics::DateTime_ExtendingNonMooseParent" : { "file" : "lib/Moose/Cookbook/Basics/DateTime_ExtendingNonMooseParent.pod", "version" : "2.1005" }, "Moose::Cookbook::Basics::Genome_OverloadingSubtypesAndCoercion" : { "file" : "lib/Moose/Cookbook/Basics/Genome_OverloadingSubtypesAndCoercion.pod", "version" : "2.1005" }, "Moose::Cookbook::Basics::HTTP_SubtypesAndCoercion" : { "file" : "lib/Moose/Cookbook/Basics/HTTP_SubtypesAndCoercion.pod", "version" : "2.1005" }, "Moose::Cookbook::Basics::Immutable" : { "file" : "lib/Moose/Cookbook/Basics/Immutable.pod", "version" : "2.1005" }, "Moose::Cookbook::Basics::Person_BUILDARGSAndBUILD" : { "file" : "lib/Moose/Cookbook/Basics/Person_BUILDARGSAndBUILD.pod", "version" : "2.1005" }, "Moose::Cookbook::Basics::Point_AttributesAndSubclassing" : { "file" : "lib/Moose/Cookbook/Basics/Point_AttributesAndSubclassing.pod", "version" : "2.1005" }, "Moose::Cookbook::Extending::Debugging_BaseClassRole" : { "file" : "lib/Moose/Cookbook/Extending/Debugging_BaseClassRole.pod", "version" : "2.1005" }, "Moose::Cookbook::Extending::ExtensionOverview" : { "file" : "lib/Moose/Cookbook/Extending/ExtensionOverview.pod", "version" : "2.1005" }, "Moose::Cookbook::Extending::Mooseish_MooseSugar" : { "file" : "lib/Moose/Cookbook/Extending/Mooseish_MooseSugar.pod", "version" : "2.1005" }, "Moose::Cookbook::Legacy::Debugging_BaseClassReplacement" : { "file" : "lib/Moose/Cookbook/Legacy/Debugging_BaseClassReplacement.pod", "version" : "2.1005" }, "Moose::Cookbook::Meta::GlobRef_InstanceMetaclass" : { "file" : "lib/Moose/Cookbook/Meta/GlobRef_InstanceMetaclass.pod", "version" : "2.1005" }, "Moose::Cookbook::Meta::Labeled_AttributeMetaclass" : { "file" : "lib/Moose/Cookbook/Legacy/Labeled_AttributeMetaclass.pod", "version" : "2.1005" }, "Moose::Cookbook::Meta::Labeled_AttributeTrait" : { "file" : "lib/Moose/Cookbook/Meta/Labeled_AttributeTrait.pod", "version" : "2.1005" }, "Moose::Cookbook::Meta::PrivateOrPublic_MethodMetaclass" : { "file" : "lib/Moose/Cookbook/Meta/PrivateOrPublic_MethodMetaclass.pod", "version" : "2.1005" }, "Moose::Cookbook::Meta::Table_ClassMetaclass" : { "file" : "lib/Moose/Cookbook/Legacy/Table_ClassMetaclass.pod", "version" : "2.1005" }, "Moose::Cookbook::Meta::Table_MetaclassTrait" : { "file" : "lib/Moose/Cookbook/Meta/Table_MetaclassTrait.pod", "version" : "2.1005" }, "Moose::Cookbook::Meta::WhyMeta" : { "file" : "lib/Moose/Cookbook/Meta/WhyMeta.pod", "version" : "2.1005" }, "Moose::Cookbook::Roles::ApplicationToInstance" : { "file" : "lib/Moose/Cookbook/Roles/ApplicationToInstance.pod", "version" : "2.1005" }, "Moose::Cookbook::Roles::Comparable_CodeReuse" : { "file" : "lib/Moose/Cookbook/Roles/Comparable_CodeReuse.pod", "version" : "2.1005" }, "Moose::Cookbook::Snack::Keywords" : { "file" : "lib/Moose/Cookbook/Snack/Keywords.pod", "version" : "2.1005" }, "Moose::Cookbook::Snack::Types" : { "file" : "lib/Moose/Cookbook/Snack/Types.pod", "version" : "2.1005" }, "Moose::Cookbook::Style" : { "file" : "lib/Moose/Cookbook/Style.pod", "version" : "2.1005" }, "Moose::Error::Confess" : { "file" : "lib/Moose/Error/Confess.pm", "version" : "2.1005" }, "Moose::Error::Croak" : { "file" : "lib/Moose/Error/Croak.pm", "version" : "2.1005" }, "Moose::Error::Default" : { "file" : "lib/Moose/Error/Default.pm", "version" : "2.1005" }, "Moose::Exporter" : { "file" : "lib/Moose/Exporter.pm", "version" : "2.1005" }, "Moose::Intro" : { "file" : "lib/Moose/Intro.pod", "version" : "2.1005" }, "Moose::Manual" : { "file" : "lib/Moose/Manual.pod", "version" : "2.1005" }, "Moose::Manual::Attributes" : { "file" : "lib/Moose/Manual/Attributes.pod", "version" : "2.1005" }, "Moose::Manual::BestPractices" : { "file" : "lib/Moose/Manual/BestPractices.pod", "version" : "2.1005" }, "Moose::Manual::Classes" : { "file" : "lib/Moose/Manual/Classes.pod", "version" : "2.1005" }, "Moose::Manual::Concepts" : { "file" : "lib/Moose/Manual/Concepts.pod", "version" : "2.1005" }, "Moose::Manual::Construction" : { "file" : "lib/Moose/Manual/Construction.pod", "version" : "2.1005" }, "Moose::Manual::Contributing" : { "file" : "lib/Moose/Manual/Contributing.pod", "version" : "2.1005" }, "Moose::Manual::Delegation" : { "file" : "lib/Moose/Manual/Delegation.pod", "version" : "2.1005" }, "Moose::Manual::Delta" : { "file" : "lib/Moose/Manual/Delta.pod", "version" : "2.1005" }, "Moose::Manual::FAQ" : { "file" : "lib/Moose/Manual/FAQ.pod", "version" : "2.1005" }, "Moose::Manual::MOP" : { "file" : "lib/Moose/Manual/MOP.pod", "version" : "2.1005" }, "Moose::Manual::MethodModifiers" : { "file" : "lib/Moose/Manual/MethodModifiers.pod", "version" : "2.1005" }, "Moose::Manual::MooseX" : { "file" : "lib/Moose/Manual/MooseX.pod", "version" : "2.1005" }, "Moose::Manual::Roles" : { "file" : "lib/Moose/Manual/Roles.pod", "version" : "2.1005" }, "Moose::Manual::Types" : { "file" : "lib/Moose/Manual/Types.pod", "version" : "2.1005" }, "Moose::Manual::Unsweetened" : { "file" : "lib/Moose/Manual/Unsweetened.pod", "version" : "2.1005" }, "Moose::Meta::Attribute" : { "file" : "lib/Moose/Meta/Attribute.pm", "version" : "2.1005" }, "Moose::Meta::Attribute::Custom::Moose" : { "file" : "lib/Moose/Meta/Attribute.pm", "version" : "2.1005" }, "Moose::Meta::Attribute::Native" : { "file" : "lib/Moose/Meta/Attribute/Native.pm", "version" : "2.1005" }, "Moose::Meta::Attribute::Native::Trait::Array" : { "file" : "lib/Moose/Meta/Attribute/Native/Trait/Array.pm", "version" : "2.1005" }, "Moose::Meta::Attribute::Native::Trait::Bool" : { "file" : "lib/Moose/Meta/Attribute/Native/Trait/Bool.pm", "version" : "2.1005" }, "Moose::Meta::Attribute::Native::Trait::Code" : { "file" : "lib/Moose/Meta/Attribute/Native/Trait/Code.pm", "version" : "2.1005" }, "Moose::Meta::Attribute::Native::Trait::Counter" : { "file" : "lib/Moose/Meta/Attribute/Native/Trait/Counter.pm", "version" : "2.1005" }, "Moose::Meta::Attribute::Native::Trait::Hash" : { "file" : "lib/Moose/Meta/Attribute/Native/Trait/Hash.pm", "version" : "2.1005" }, "Moose::Meta::Attribute::Native::Trait::Number" : { "file" : "lib/Moose/Meta/Attribute/Native/Trait/Number.pm", "version" : "2.1005" }, "Moose::Meta::Attribute::Native::Trait::String" : { "file" : "lib/Moose/Meta/Attribute/Native/Trait/String.pm", "version" : "2.1005" }, "Moose::Meta::Class" : { "file" : "lib/Moose/Meta/Class.pm", "version" : "2.1005" }, "Moose::Meta::Instance" : { "file" : "lib/Moose/Meta/Instance.pm", "version" : "2.1005" }, "Moose::Meta::Method" : { "file" : "lib/Moose/Meta/Method.pm", "version" : "2.1005" }, "Moose::Meta::Method::Accessor" : { "file" : "lib/Moose/Meta/Method/Accessor.pm", "version" : "2.1005" }, "Moose::Meta::Method::Augmented" : { "file" : "lib/Moose/Meta/Method/Augmented.pm", "version" : "2.1005" }, "Moose::Meta::Method::Constructor" : { "file" : "lib/Moose/Meta/Method/Constructor.pm", "version" : "2.1005" }, "Moose::Meta::Method::Delegation" : { "file" : "lib/Moose/Meta/Method/Delegation.pm", "version" : "2.1005" }, "Moose::Meta::Method::Destructor" : { "file" : "lib/Moose/Meta/Method/Destructor.pm", "version" : "2.1005" }, "Moose::Meta::Method::Meta" : { "file" : "lib/Moose/Meta/Method/Meta.pm", "version" : "2.1005" }, "Moose::Meta::Method::Overridden" : { "file" : "lib/Moose/Meta/Method/Overridden.pm", "version" : "2.1005" }, "Moose::Meta::Role" : { "file" : "lib/Moose/Meta/Role.pm", "version" : "2.1005" }, "Moose::Meta::Role::Application" : { "file" : "lib/Moose/Meta/Role/Application.pm", "version" : "2.1005" }, "Moose::Meta::Role::Application::RoleSummation" : { "file" : "lib/Moose/Meta/Role/Application/RoleSummation.pm", "version" : "2.1005" }, "Moose::Meta::Role::Application::ToClass" : { "file" : "lib/Moose/Meta/Role/Application/ToClass.pm", "version" : "2.1005" }, "Moose::Meta::Role::Application::ToInstance" : { "file" : "lib/Moose/Meta/Role/Application/ToInstance.pm", "version" : "2.1005" }, "Moose::Meta::Role::Application::ToRole" : { "file" : "lib/Moose/Meta/Role/Application/ToRole.pm", "version" : "2.1005" }, "Moose::Meta::Role::Attribute" : { "file" : "lib/Moose/Meta/Role/Attribute.pm", "version" : "2.1005" }, "Moose::Meta::Role::Composite" : { "file" : "lib/Moose/Meta/Role/Composite.pm", "version" : "2.1005" }, "Moose::Meta::Role::Method" : { "file" : "lib/Moose/Meta/Role/Method.pm", "version" : "2.1005" }, "Moose::Meta::Role::Method::Conflicting" : { "file" : "lib/Moose/Meta/Role/Method/Conflicting.pm", "version" : "2.1005" }, "Moose::Meta::Role::Method::Required" : { "file" : "lib/Moose/Meta/Role/Method/Required.pm", "version" : "2.1005" }, "Moose::Meta::TypeCoercion" : { "file" : "lib/Moose/Meta/TypeCoercion.pm", "version" : "2.1005" }, "Moose::Meta::TypeCoercion::Union" : { "file" : "lib/Moose/Meta/TypeCoercion/Union.pm", "version" : "2.1005" }, "Moose::Meta::TypeConstraint" : { "file" : "lib/Moose/Meta/TypeConstraint.pm", "version" : "2.1005" }, "Moose::Meta::TypeConstraint::Class" : { "file" : "lib/Moose/Meta/TypeConstraint/Class.pm", "version" : "2.1005" }, "Moose::Meta::TypeConstraint::DuckType" : { "file" : "lib/Moose/Meta/TypeConstraint/DuckType.pm", "version" : "2.1005" }, "Moose::Meta::TypeConstraint::Enum" : { "file" : "lib/Moose/Meta/TypeConstraint/Enum.pm", "version" : "2.1005" }, "Moose::Meta::TypeConstraint::Parameterizable" : { "file" : "lib/Moose/Meta/TypeConstraint/Parameterizable.pm", "version" : "2.1005" }, "Moose::Meta::TypeConstraint::Parameterized" : { "file" : "lib/Moose/Meta/TypeConstraint/Parameterized.pm", "version" : "2.1005" }, "Moose::Meta::TypeConstraint::Registry" : { "file" : "lib/Moose/Meta/TypeConstraint/Registry.pm", "version" : "2.1005" }, "Moose::Meta::TypeConstraint::Role" : { "file" : "lib/Moose/Meta/TypeConstraint/Role.pm", "version" : "2.1005" }, "Moose::Meta::TypeConstraint::Union" : { "file" : "lib/Moose/Meta/TypeConstraint/Union.pm", "version" : "2.1005" }, "Moose::Object" : { "file" : "lib/Moose/Object.pm", "version" : "2.1005" }, "Moose::Role" : { "file" : "lib/Moose/Role.pm", "version" : "2.1005" }, "Moose::Spec::Role" : { "file" : "lib/Moose/Spec/Role.pod", "version" : "2.1005" }, "Moose::Unsweetened" : { "file" : "lib/Moose/Unsweetened.pod", "version" : "2.1005" }, "Moose::Util" : { "file" : "lib/Moose/Util.pm", "version" : "2.1005" }, "Moose::Util::MetaRole" : { "file" : "lib/Moose/Util/MetaRole.pm", "version" : "2.1005" }, "Moose::Util::TypeConstraints" : { "file" : "lib/Moose/Util/TypeConstraints.pm", "version" : "2.1005" }, "Test::Moose" : { "file" : "lib/Test/Moose.pm", "version" : "2.1005" }, "metaclass" : { "file" : "lib/metaclass.pm", "version" : "2.1005" }, "oose" : { "file" : "lib/oose.pm", "version" : "2.1005" } }, "release_status" : "stable", "resources" : { "bugtracker" : { "mailto" : "bug-moose@rt.cpan.org", "web" : "https://rt.cpan.org/Dist/Display.html?Name=Moose" }, "repository" : { "type" : "git", "url" : "git://github.com/moose/moose.git", "web" : "https://github.com/moose/moose" } }, "version" : "2.1005", "x_Dist_Zilla" : { "perl" : { "version" : "5.019002" }, "plugins" : [ { "class" : "inc::RequireAuthorDeps", "name" : "=inc::RequireAuthorDeps", "version" : null }, { "class" : "inc::Clean", "name" : "=inc::Clean", "version" : null }, { "class" : "Dist::Zilla::Plugin::GatherDir", "name" : "GatherDir", "version" : "4.300035" }, { "class" : "Dist::Zilla::Plugin::PruneCruft", "name" : "PruneCruft", "version" : "4.300035" }, { "class" : "Dist::Zilla::Plugin::ManifestSkip", "name" : "ManifestSkip", "version" : "4.300035" }, { "class" : "Dist::Zilla::Plugin::MetaYAML", "name" : "MetaYAML", "version" : "4.300035" }, { "class" : "Dist::Zilla::Plugin::MetaJSON", "name" : "MetaJSON", "version" : "4.300035" }, { "class" : "Dist::Zilla::Plugin::License", "name" : "License", "version" : "4.300035" }, { "class" : "Dist::Zilla::Plugin::ExecDir", "name" : "ExecDir", "version" : "4.300035" }, { "class" : "Dist::Zilla::Plugin::ShareDir", "name" : "ShareDir", "version" : "4.300035" }, { "class" : "inc::MakeMaker", "name" : "=inc::MakeMaker", "version" : null }, { "class" : "Dist::Zilla::Plugin::Manifest", "name" : "Manifest", "version" : "4.300035" }, { "class" : "Dist::Zilla::Plugin::TestRelease", "name" : "TestRelease", "version" : "4.300035" }, { "class" : "Dist::Zilla::Plugin::UploadToCPAN", "name" : "UploadToCPAN", "version" : "4.300035" }, { "class" : "Dist::Zilla::Plugin::NextRelease", "name" : "NextRelease", "version" : "4.300035" }, { "class" : "Dist::Zilla::Plugin::PruneFiles", "name" : "PruneFiles", "version" : "4.300035" }, { "class" : "Dist::Zilla::Plugin::PkgVersion", "name" : "PkgVersion", "version" : "4.300035" }, { "class" : "Dist::Zilla::Plugin::MetaConfig", "name" : "MetaConfig", "version" : "4.300035" }, { "class" : "Dist::Zilla::Plugin::Authority", "name" : "Authority", "version" : "1.006" }, { "class" : "Dist::Zilla::Plugin::MetaResources", "name" : "MetaResources", "version" : "4.300035" }, { "class" : "Dist::Zilla::Plugin::MetaProvides::Package", "name" : "MetaProvides::Package", "version" : "1.14000003" }, { "class" : "Dist::Zilla::Plugin::MetaNoIndex", "name" : "MetaNoIndex", "version" : "4.300035" }, { "class" : "Dist::Zilla::Plugin::SurgicalPodWeaver", "name" : "SurgicalPodWeaver", "version" : "0.0020" }, { "class" : "inc::ExtractInlineTests", "name" : "=inc::ExtractInlineTests", "version" : null }, { "class" : "Dist::Zilla::Plugin::EOLTests", "name" : "EOLTests", "version" : "0.02" }, { "class" : "Dist::Zilla::Plugin::PodSyntaxTests", "name" : "PodSyntaxTests", "version" : "4.300035" }, { "class" : "Dist::Zilla::Plugin::NoTabsTests", "name" : "NoTabsTests", "version" : "0.01" }, { "class" : "Dist::Zilla::Plugin::RunExtraTests", "name" : "RunExtraTests", "version" : "0.011" }, { "class" : "Dist::Zilla::Plugin::Test::CheckDeps", "name" : "Test::CheckDeps", "version" : "0.007" }, { "class" : "Dist::Zilla::Plugin::Test::ChangesHasContent", "name" : "Test::ChangesHasContent", "version" : "0.006" }, { "class" : "Dist::Zilla::Plugin::CheckChangesHasContent", "name" : "CheckChangesHasContent", "version" : "0.006" }, { "class" : "Dist::Zilla::Plugin::Prereqs", "config" : { "Dist::Zilla::Plugin::Prereqs" : { "phase" : "runtime", "type" : "requires" } }, "name" : "Prereqs", "version" : "4.300035" }, { "class" : "Dist::Zilla::Plugin::Prereqs", "config" : { "Dist::Zilla::Plugin::Prereqs" : { "phase" : "test", "type" : "requires" } }, "name" : "TestRequires", "version" : "4.300035" }, { "class" : "Dist::Zilla::Plugin::Prereqs", "config" : { "Dist::Zilla::Plugin::Prereqs" : { "phase" : "develop", "type" : "requires" } }, "name" : "DevelopRequires", "version" : "4.300035" }, { "class" : "Dist::Zilla::Plugin::Prereqs", "config" : { "Dist::Zilla::Plugin::Prereqs" : { "phase" : "runtime", "type" : "recommends" } }, "name" : "RuntimeRecommends", "version" : "4.300035" }, { "class" : "Dist::Zilla::Plugin::Prereqs", "config" : { "Dist::Zilla::Plugin::Prereqs" : { "phase" : "develop", "type" : "conflicts" } }, "name" : "DevelopConflicts", "version" : "4.300035" }, { "class" : "Dist::Zilla::Plugin::Conflicts", "name" : "Conflicts", "version" : "0.10" }, { "class" : "inc::CheckDelta", "name" : "=inc::CheckDelta", "version" : null }, { "class" : "inc::GitUpToDate", "name" : "=inc::GitUpToDate", "version" : null }, { "class" : "Dist::Zilla::Plugin::Git::Remote::Check", "name" : "Git::Remote::Check", "version" : "0.1.2" }, { "class" : "Dist::Zilla::Plugin::Git::CheckFor::CorrectBranch", "name" : "Git::CheckFor::CorrectBranch", "version" : "0.006" }, { "class" : "Dist::Zilla::Plugin::Git::Check", "name" : "Git::Check", "version" : "2.014" }, { "class" : "Dist::Zilla::Plugin::ConfirmRelease", "name" : "ConfirmRelease", "version" : "4.300035" }, { "class" : "Dist::Zilla::Plugin::Git::Commit", "name" : "Git::Commit", "version" : "2.014" }, { "class" : "Dist::Zilla::Plugin::Git::Tag", "name" : "Git::Tag", "version" : "2.014" }, { "class" : "Dist::Zilla::Plugin::Git::Push", "name" : "Git::Push", "version" : "2.014" }, { "class" : "Dist::Zilla::Plugin::FinderCode", "name" : ":InstallModules", "version" : "4.300035" }, { "class" : "Dist::Zilla::Plugin::FinderCode", "name" : ":IncModules", "version" : "4.300035" }, { "class" : "Dist::Zilla::Plugin::FinderCode", "name" : ":TestFiles", "version" : "4.300035" }, { "class" : "Dist::Zilla::Plugin::FinderCode", "name" : ":ExecFiles", "version" : "4.300035" }, { "class" : "Dist::Zilla::Plugin::FinderCode", "name" : ":ShareFiles", "version" : "4.300035" }, { "class" : "Dist::Zilla::Plugin::FinderCode", "name" : ":MainModule", "version" : "4.300035" } ], "zilla" : { "class" : "Dist::Zilla::Dist::Builder", "config" : { "is_trial" : "0" }, "version" : "4.300035" } }, "x_authority" : "cpan:STEVAN", "x_breaks" : { "Catalyst" : "5.80028", "Devel::REPL" : "1.003008", "Fey" : "0.36", "Fey::ORM" : "0.42", "File::ChangeNotify" : "0.15", "KiokuDB" : "0.51", "Markdent" : "0.16", "Mason" : "2.18", "MooseX::ABC" : "0.05", "MooseX::Aliases" : "0.08", "MooseX::AlwaysCoerce" : "0.13", "MooseX::App" : "1.18", "MooseX::Attribute::Deflator" : "2.1.7", "MooseX::Attribute::Dependent" : "1.1.0", "MooseX::Attribute::Prototype" : "0.10", "MooseX::AttributeHelpers" : "0.22", "MooseX::AttributeIndexes" : "1.0.0", "MooseX::AttributeInflate" : "0.02", "MooseX::CascadeClearing" : "0.03", "MooseX::ClassAttribute" : "0.26", "MooseX::Constructor::AllErrors" : "0.012", "MooseX::FollowPBP" : "0.02", "MooseX::HasDefaults" : "0.02", "MooseX::InstanceTracking" : "0.04", "MooseX::LazyRequire" : "0.06", "MooseX::Meta::Attribute::Index" : "0.04", "MooseX::Meta::Attribute::Lvalue" : "0.05", "MooseX::MethodAttributes" : "0.22", "MooseX::NonMoose" : "0.17", "MooseX::POE" : "0.214", "MooseX::Params::Validate" : "0.05", "MooseX::PrivateSetters" : "0.03", "MooseX::Role::Cmd" : "0.06", "MooseX::Role::Parameterized" : "0.23", "MooseX::Role::WithOverloading" : "0.07", "MooseX::Scaffold" : "0.05", "MooseX::SemiAffordanceAccessor" : "0.05", "MooseX::SetOnce" : "0.100473", "MooseX::Singleton" : "0.25", "MooseX::SlurpyConstructor" : "1.1", "MooseX::StrictConstructor" : "0.12", "MooseX::Types" : "0.19", "MooseX::Types::Parameterizable" : "0.05", "MooseX::Types::Signal" : "1.101930", "MooseX::UndefTolerant" : "0.11", "PRANG" : "0.14", "Pod::Elemental" : "0.093280", "Reaction" : "0.002003", "Test::Able" : "0.10", "namespace::autoclean" : "0.08" } } perltidyrc100644000767000024 43712200352344 14424 0ustar00etherstaff000000000000Moose-2.1005-l=78 -i=4 -ci=4 -se -b -bar -boc -vt=0 -vtc=0 -cti=0 -pt=1 -bt=1 -sbt=1 -bbt=1 -nolq -npro -nsfs --opening-hash-brace-right --no-outdent-long-comments --blank-lines-before-packages=0 -wbb="% + - * / x != == >= <= =~ !~ < > | & >= < = **= += *= &= <<= &&= -= /= |= >>= ||= .= %= ^= x=" typemap100644000767000024 76412200352344 14357 0ustar00etherstaff000000000000Moose-2.1005/xstype_filter_t T_TYPE_FILTER INPUT T_TYPE_FILTER { const char *__tMp = SvPV_nolen($arg); switch (*__tMp) { case 'C': $var = TYPE_FILTER_CODE; break; case 'A': $var = TYPE_FILTER_ARRAY; break; case 'I': $var = TYPE_FILTER_IO; break; case 'H': $var = TYPE_FILTER_HASH; break; case 'S': $var = TYPE_FILTER_SCALAR; break; default: croak(\"Unknown type %s\\n\", __tMp); } } lib000755000767000024 012200352344 12742 5ustar00etherstaff000000000000Moose-2.1005oose.pm100644000767000024 451312200352344 14410 0ustar00etherstaff000000000000Moose-2.1005/libpackage oose; BEGIN { $oose::AUTHORITY = 'cpan:STEVAN'; } { $oose::VERSION = '2.1005'; } use strict; use warnings; use Class::Load qw(load_class); BEGIN { my $package; sub import { $package = $_[1] || 'Class'; if ($package =~ /^\+/) { $package =~ s/^\+//; load_class($package); } } use Filter::Simple sub { s/^/package $package;\nuse Moose;use Moose::Util::TypeConstraints;\n/; } } 1; # ABSTRACT: syntactic sugar to make Moose one-liners easier __END__ =pod =head1 NAME oose - syntactic sugar to make Moose one-liners easier =head1 VERSION version 2.1005 =head1 SYNOPSIS # create a Moose class on the fly ... perl -Moose=Foo -e 'has bar => ( is=>q[ro], default => q[baz] ); print Foo->new->bar' # prints baz # loads an existing class (Moose or non-Moose) # and re-"opens" the package definition to make # debugging/introspection easier perl -Moose=+My::Class -e 'print join ", " => __PACKAGE__->meta->get_method_list' # also loads Moose::Util::TypeConstraints to allow subtypes etc perl -Moose=Person -e'subtype q[ValidAge] => as q[Int] => where { $_ > 0 && $_ < 78 }; has => age ( isa => q[ValidAge], is => q[ro]); Person->new(age => 90)' =head1 DESCRIPTION oose.pm is a simple source filter that adds C to the beginning of your script and was entirely created because typing C was annoying me. =head1 INTERFACE oose provides exactly one method and it's automatically called by perl: =over 4 =item B Pass a package name to import to be used by the source filter. The package defaults to C if none is given. =back =head1 DEPENDENCIES You will need L and eventually L =head1 INCOMPATIBILITIES None reported. But it is a source filter and might have issues there. =head1 BUGS See L for details on reporting bugs. =head1 AUTHOR Moose is maintained by the Moose Cabal, along with the help of many contributors. See L and L for details. =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2013 by Infinity Interactive, Inc.. This is free software; you can redistribute it and/or modify it under the same terms as the Perl 5 programming language system itself. =cut Class.xs100644000767000024 55512200352344 14374 0ustar00etherstaff000000000000Moose-2.1005/xs#include "mop.h" MODULE = Class::MOP::Class PACKAGE = Class::MOP::Class PROTOTYPES: DISABLE BOOT: INSTALL_SIMPLE_READER(Class, instance_metaclass); INSTALL_SIMPLE_READER(Class, immutable_trait); INSTALL_SIMPLE_READER(Class, constructor_class); INSTALL_SIMPLE_READER(Class, constructor_name); INSTALL_SIMPLE_READER(Class, destructor_class); Moose.xs100644000767000024 711312200352344 14426 0ustar00etherstaff000000000000Moose-2.1005/xs#include "EXTERN.h" #include "perl.h" #include "XSUB.h" #include "ppport.h" #include "mop.h" #ifndef MGf_COPY # define MGf_COPY 0 #endif #ifndef MGf_DUP # define MGf_DUP 0 #endif #ifndef MGf_LOCAL # define MGf_LOCAL 0 #endif STATIC int unset_export_flag (pTHX_ SV *sv, MAGIC *mg); STATIC MGVTBL export_flag_vtbl = { NULL, /* get */ unset_export_flag, /* set */ NULL, /* len */ NULL, /* clear */ NULL, /* free */ #if MGf_COPY NULL, /* copy */ #endif #if MGf_DUP NULL, /* dup */ #endif #if MGf_LOCAL NULL, /* local */ #endif }; STATIC bool export_flag_is_set (pTHX_ SV *sv) { MAGIC *mg, *moremagic; if (SvTYPE(SvRV(sv)) != SVt_PVGV) { return 0; } for (mg = SvMAGIC(SvRV(sv)); mg; mg = moremagic) { moremagic = mg->mg_moremagic; if (mg->mg_type == PERL_MAGIC_ext && mg->mg_virtual == &export_flag_vtbl) { break; } } return !!mg; } STATIC int unset_export_flag (pTHX_ SV *sv, MAGIC *mymg) { MAGIC *mg, *prevmagic = NULL, *moremagic = NULL; for (mg = SvMAGIC(sv); mg; prevmagic = mg, mg = moremagic) { moremagic = mg->mg_moremagic; if (mg == mymg) { break; } } if (!mg) { return 0; } if (prevmagic) { prevmagic->mg_moremagic = moremagic; } else { SvMAGIC_set(sv, moremagic); } mg->mg_moremagic = NULL; Safefree (mg); return 0; } #ifndef SvRXOK /* SvRXOK appeared before SVt_REGEXP did, so this implementation assumes magic * based qr//. Note re::is_regexp isn't in 5.8, hence the need for this XS. */ #define SvRXOK(sv) is_regexp(aTHX_ sv) STATIC int is_regexp (pTHX_ SV* sv) { SV* tmpsv; if (SvMAGICAL(sv)) { mg_get(sv); } if (SvROK(sv) && (tmpsv = (SV*) SvRV(sv)) && SvTYPE(tmpsv) == SVt_PVMG && (mg_find(tmpsv, PERL_MAGIC_qr))) { return TRUE; } return FALSE; } #endif XS_EXTERNAL(boot_Class__MOP); XS_EXTERNAL(boot_Class__MOP__Mixin__HasAttributes); XS_EXTERNAL(boot_Class__MOP__Mixin__HasMethods); XS_EXTERNAL(boot_Class__MOP__Package); XS_EXTERNAL(boot_Class__MOP__Mixin__AttributeCore); XS_EXTERNAL(boot_Class__MOP__Method); XS_EXTERNAL(boot_Class__MOP__Method__Inlined); XS_EXTERNAL(boot_Class__MOP__Method__Generated); XS_EXTERNAL(boot_Class__MOP__Method__Overload); XS_EXTERNAL(boot_Class__MOP__Class); XS_EXTERNAL(boot_Class__MOP__Attribute); XS_EXTERNAL(boot_Class__MOP__Instance); MODULE = Moose PACKAGE = Moose::Exporter PROTOTYPES: DISABLE BOOT: mop_prehash_keys(); MOP_CALL_BOOT (boot_Class__MOP); MOP_CALL_BOOT (boot_Class__MOP__Mixin__HasAttributes); MOP_CALL_BOOT (boot_Class__MOP__Mixin__HasMethods); MOP_CALL_BOOT (boot_Class__MOP__Package); MOP_CALL_BOOT (boot_Class__MOP__Mixin__AttributeCore); MOP_CALL_BOOT (boot_Class__MOP__Method); MOP_CALL_BOOT (boot_Class__MOP__Method__Inlined); MOP_CALL_BOOT (boot_Class__MOP__Method__Generated); MOP_CALL_BOOT (boot_Class__MOP__Method__Overload); MOP_CALL_BOOT (boot_Class__MOP__Class); MOP_CALL_BOOT (boot_Class__MOP__Attribute); MOP_CALL_BOOT (boot_Class__MOP__Instance); void _flag_as_reexport (SV *sv) CODE: sv_magicext(SvRV(sv), NULL, PERL_MAGIC_ext, &export_flag_vtbl, NULL, 0); bool _export_is_flagged (SV *sv) CODE: RETVAL = export_flag_is_set(aTHX_ sv); OUTPUT: RETVAL MODULE = Moose PACKAGE = Moose::Util::TypeConstraints::Builtins bool _RegexpRef (SV *sv=NULL) INIT: if (!items) { sv = DEFSV; } CODE: RETVAL = SvRXOK(sv); OUTPUT: RETVAL Makefile.PL100644000767000024 1211012200352344 14321 0ustar00etherstaff000000000000Moose-2.1005# This Makefile.PL for was generated by Dist::Zilla. # Don't edit it but the dist.ini used to construct it. use strict; use warnings; use v5.8.3; use ExtUtils::MakeMaker 6.30; check_conflicts(); my %WriteMakefileArgs = ( "ABSTRACT" => "A postmodern object system for Perl 5", "AUTHOR" => "Moose is maintained by the Moose Cabal, along with the help of many contributors. See L and L for details.", "BUILD_REQUIRES" => {}, "CONFIGURE_REQUIRES" => { "Dist::CheckConflicts" => "0.02", "ExtUtils::MakeMaker" => "6.30" }, "DISTNAME" => "Moose", "EXE_FILES" => [ "bin/moose-outdated" ], "LICENSE" => "perl", "MIN_PERL_VERSION" => "5.008003", "NAME" => "Moose", "OBJECT" => "xs/Attribute\$(OBJ_EXT) xs/AttributeCore\$(OBJ_EXT) xs/Class\$(OBJ_EXT) xs/Generated\$(OBJ_EXT) xs/HasAttributes\$(OBJ_EXT) xs/HasMethods\$(OBJ_EXT) xs/Inlined\$(OBJ_EXT) xs/Instance\$(OBJ_EXT) xs/Method\$(OBJ_EXT) xs/Moose\$(OBJ_EXT) xs/MOP\$(OBJ_EXT) xs/Overload\$(OBJ_EXT) xs/Package\$(OBJ_EXT) mop\$(OBJ_EXT)", "PREREQ_PM" => { "Carp" => "1.22", "Class::Load" => "0.09", "Class::Load::XS" => "0.01", "Data::OptList" => "0.107", "Devel::GlobalDestruction" => "0", "Dist::CheckConflicts" => "0.02", "Eval::Closure" => "0.04", "List::MoreUtils" => "0.28", "MRO::Compat" => "0.05", "Package::DeprecationManager" => "0.11", "Package::Stash" => "0.32", "Package::Stash::XS" => "0.24", "Params::Util" => "1.00", "Scalar::Util" => "1.19", "Sub::Exporter" => "0.980", "Sub::Name" => "0.05", "Task::Weaken" => "0", "Try::Tiny" => "0.02" }, "TEST_REQUIRES" => { "CPAN::Meta::Check" => "0.007", "Test::CheckDeps" => "0.006", "Test::Fatal" => "0.001", "Test::More" => "0.94", "Test::Requires" => "0.05" }, "VERSION" => "2.1005", "XS" => { "xs/Attribute.xs" => "xs/Attribute.c", "xs/AttributeCore.xs" => "xs/AttributeCore.c", "xs/Class.xs" => "xs/Class.c", "xs/Generated.xs" => "xs/Generated.c", "xs/HasAttributes.xs" => "xs/HasAttributes.c", "xs/HasMethods.xs" => "xs/HasMethods.c", "xs/Inlined.xs" => "xs/Inlined.c", "xs/Instance.xs" => "xs/Instance.c", "xs/MOP.xs" => "xs/MOP.c", "xs/Method.xs" => "xs/Method.c", "xs/Moose.xs" => "xs/Moose.c", "xs/Overload.xs" => "xs/Overload.c", "xs/Package.xs" => "xs/Package.c" }, "clean" => { "FILES" => "xs/Attribute\$(OBJ_EXT) xs/AttributeCore\$(OBJ_EXT) xs/Class\$(OBJ_EXT) xs/Generated\$(OBJ_EXT) xs/HasAttributes\$(OBJ_EXT) xs/HasMethods\$(OBJ_EXT) xs/Inlined\$(OBJ_EXT) xs/Instance\$(OBJ_EXT) xs/Method\$(OBJ_EXT) xs/Moose\$(OBJ_EXT) xs/MOP\$(OBJ_EXT) xs/Overload\$(OBJ_EXT) xs/Package\$(OBJ_EXT) mop\$(OBJ_EXT)" }, "test" => { "TESTS" => "t/*.t t/attributes/*.t t/basics/*.t t/bugs/*.t t/cmop/*.t t/compat/*.t t/examples/*.t t/immutable/*.t t/metaclasses/*.t t/moose_util/*.t t/native_traits/*.t t/recipes/*.t t/roles/*.t t/test_moose/*.t t/todo_tests/*.t t/type_constraints/*.t" } ); unless ( eval { ExtUtils::MakeMaker->VERSION(6.63_03) } ) { my $tr = delete $WriteMakefileArgs{TEST_REQUIRES}; my $br = $WriteMakefileArgs{BUILD_REQUIRES}; for my $mod ( keys %$tr ) { if ( exists $br->{$mod} ) { $br->{$mod} = $tr->{$mod} if $tr->{$mod} > $br->{$mod}; } else { $br->{$mod} = $tr->{$mod}; } } } unless ( eval { ExtUtils::MakeMaker->VERSION(6.56) } ) { my $br = delete $WriteMakefileArgs{BUILD_REQUIRES}; my $pp = $WriteMakefileArgs{PREREQ_PM}; for my $mod ( keys %$br ) { if ( exists $pp->{$mod} ) { $pp->{$mod} = $br->{$mod} if $br->{$mod} > $pp->{$mod}; } else { $pp->{$mod} = $br->{$mod}; } } } delete $WriteMakefileArgs{CONFIGURE_REQUIRES} unless eval { ExtUtils::MakeMaker->VERSION(6.52) }; $WriteMakefileArgs{CCFLAGS} = ( $Config::Config{ccflags} || '' ) . ' -I.'; WriteMakefile(%WriteMakefileArgs); { package MY; use Config; sub const_cccmd { my $ret = shift->SUPER::const_cccmd(@_); return q{} unless $ret; if ($Config{cc} =~ /^cl\b/i) { warn 'you are using MSVC... my condolences.'; $ret .= ' /Fo$@'; } else { $ret .= ' -o $@'; } return $ret; } sub postamble { return <<'EOF'; $(OBJECT) : mop.h EOF } } sub check_conflicts { if ( eval { require 'lib/Moose/Conflicts.pm'; 1; } ) { if ( eval { Moose::Conflicts->check_conflicts; 1 } ) { return; } else { my $err = $@; $err =~ s/^/ /mg; warn "***\n$err***\n"; } } else { print <<'EOF'; *** Your toolchain doesn't support configure_requires, so Dist::CheckConflicts hasn't been installed yet. You should check for conflicting modules manually using the 'moose-outdated' script that is installed with this distribution once the installation finishes. *** EOF } return if $ENV{AUTOMATED_TESTING} || $ENV{NONINTERACTIVE_TESTING}; # More or less copied from Module::Build return if $ENV{PERL_MM_USE_DEFAULT}; return unless -t STDIN && ( -t STDOUT || !( -f STDOUT || -c STDOUT ) ); sleep 4; } inc000755000767000024 012200352344 12745 5ustar00etherstaff000000000000Moose-2.1005Clean.pm100644000767000024 103612200352344 14465 0ustar00etherstaff000000000000Moose-2.1005/incpackage inc::Clean; use Moose; with 'Dist::Zilla::Role::BeforeBuild'; sub before_build { my $self = shift; if (-e 'Makefile') { $self->log("Running make distclean to clear out build cruft"); unless (fork) { close(STDIN); close(STDOUT); close(STDERR); { exec("$^X Makefile.PL && make distclean") } die "couldn't exec: $!"; } } if (-e 'META.yml') { $self->log("Removing existing META.yml file"); unlink('META.yml'); } } Moose.pm100644000767000024 11237112200352344 14567 0ustar00etherstaff000000000000Moose-2.1005/libpackage Moose; BEGIN { $Moose::AUTHORITY = 'cpan:STEVAN'; } { $Moose::VERSION = '2.1005'; } use strict; use warnings; use 5.008; use Scalar::Util 'blessed'; use Carp 'carp', 'confess'; use Class::Load 'is_class_loaded'; use Moose::Deprecated; use Moose::Exporter; use Class::MOP; BEGIN { die "Class::MOP version $Moose::VERSION required--this is version $Class::MOP::VERSION" if $Moose::VERSION && $Class::MOP::VERSION ne $Moose::VERSION; } use Moose::Meta::Class; use Moose::Meta::TypeConstraint; use Moose::Meta::TypeCoercion; use Moose::Meta::Attribute; use Moose::Meta::Instance; use Moose::Object; use Moose::Meta::Role; use Moose::Meta::Role::Composite; use Moose::Meta::Role::Application; use Moose::Meta::Role::Application::RoleSummation; use Moose::Meta::Role::Application::ToClass; use Moose::Meta::Role::Application::ToRole; use Moose::Meta::Role::Application::ToInstance; use Moose::Util::TypeConstraints; use Moose::Util (); use Moose::Meta::Attribute::Native; sub throw_error { # FIXME This shift; goto \&confess } sub extends { my $meta = shift; Moose->throw_error("Must derive at least one class") unless @_; # this checks the metaclass to make sure # it is correct, sometimes it can get out # of sync when the classes are being built $meta->superclasses(@_); } sub with { Moose::Util::apply_all_roles(shift, @_); } sub has { my $meta = shift; my $name = shift; Moose->throw_error('Usage: has \'name\' => ( key => value, ... )') if @_ % 2 == 1; my %context = Moose::Util::_caller_info; $context{context} = 'has declaration'; $context{type} = 'class'; my %options = ( definition_context => \%context, @_ ); my $attrs = ( ref($name) eq 'ARRAY' ) ? $name : [ ($name) ]; $meta->add_attribute( $_, %options ) for @$attrs; } sub before { Moose::Util::add_method_modifier(shift, 'before', \@_); } sub after { Moose::Util::add_method_modifier(shift, 'after', \@_); } sub around { Moose::Util::add_method_modifier(shift, 'around', \@_); } our $SUPER_PACKAGE; our $SUPER_BODY; our @SUPER_ARGS; sub super { if (@_) { carp 'Arguments passed to super() are ignored'; } # This check avoids a recursion loop - see # t/bugs/super_recursion.t return if defined $SUPER_PACKAGE && $SUPER_PACKAGE ne caller(); return unless $SUPER_BODY; $SUPER_BODY->(@SUPER_ARGS); } sub override { my $meta = shift; my ( $name, $method ) = @_; $meta->add_override_method_modifier( $name => $method ); } sub inner { my $pkg = caller(); our ( %INNER_BODY, %INNER_ARGS ); if ( my $body = $INNER_BODY{$pkg} ) { my @args = @{ $INNER_ARGS{$pkg} }; local $INNER_ARGS{$pkg}; local $INNER_BODY{$pkg}; return $body->(@args); } else { return; } } sub augment { my $meta = shift; my ( $name, $method ) = @_; $meta->add_augment_method_modifier( $name => $method ); } Moose::Exporter->setup_import_methods( with_meta => [ qw( extends with has before after around override augment ) ], as_is => [ qw( super inner ), \&Carp::confess, \&Scalar::Util::blessed, ], ); sub init_meta { shift; my %args = @_; my $class = $args{for_class} or Moose->throw_error("Cannot call init_meta without specifying a for_class"); my $base_class = $args{base_class} || 'Moose::Object'; my $metaclass = $args{metaclass} || 'Moose::Meta::Class'; my $meta_name = exists $args{meta_name} ? $args{meta_name} : 'meta'; Moose->throw_error("The Metaclass $metaclass must be loaded. (Perhaps you forgot to 'use $metaclass'?)") unless is_class_loaded($metaclass); Moose->throw_error("The Metaclass $metaclass must be a subclass of Moose::Meta::Class.") unless $metaclass->isa('Moose::Meta::Class'); # make a subtype for each Moose class class_type($class) unless find_type_constraint($class); my $meta; if ( $meta = Class::MOP::get_metaclass_by_name($class) ) { unless ( $meta->isa("Moose::Meta::Class") ) { my $error_message = "$class already has a metaclass, but it does not inherit $metaclass ($meta)."; if ( $meta->isa('Moose::Meta::Role') ) { Moose->throw_error($error_message . ' You cannot make the same thing a role and a class. Remove either Moose or Moose::Role.'); } else { Moose->throw_error($error_message); } } } else { # no metaclass # now we check whether our ancestors have metaclass, and if so borrow that my ( undef, @isa ) = @{ mro::get_linear_isa($class) }; foreach my $ancestor ( @isa ) { my $ancestor_meta = Class::MOP::get_metaclass_by_name($ancestor) || next; my $ancestor_meta_class = $ancestor_meta->_real_ref_name; # if we have an ancestor metaclass that inherits $metaclass, we use # that. This is like _fix_metaclass_incompatibility, but we can do it now. # the case of having an ancestry is not very common, but arises in # e.g. Reaction unless ( $metaclass->isa( $ancestor_meta_class ) ) { if ( $ancestor_meta_class->isa($metaclass) ) { $metaclass = $ancestor_meta_class; } } } $meta = $metaclass->initialize($class); } if (defined $meta_name) { # also check for inherited non moose 'meta' method? my $existing = $meta->get_method($meta_name); if ($existing && !$existing->isa('Class::MOP::Method::Meta')) { Carp::cluck "Moose is overwriting an existing method named " . "$meta_name in class $class with a method " . "which returns the class's metaclass. If this is " . "actually what you want, you should remove the " . "existing method, otherwise, you should rename or " . "disable this generated method using the " . "'-meta_name' option to 'use Moose'."; } $meta->_add_meta_method($meta_name); } # make sure they inherit from Moose::Object $meta->superclasses($base_class) unless $meta->superclasses(); return $meta; } # This may be used in some older MooseX extensions. sub _get_caller { goto &Moose::Exporter::_get_caller; } ## make 'em all immutable $_->make_immutable( inline_constructor => 1, constructor_name => "_new", # these are Class::MOP accessors, so they need inlining inline_accessors => 1 ) for grep { $_->is_mutable } map { $_->meta } qw( Moose::Meta::Attribute Moose::Meta::Class Moose::Meta::Instance Moose::Meta::TypeCoercion Moose::Meta::TypeCoercion::Union Moose::Meta::Method Moose::Meta::Method::Constructor Moose::Meta::Method::Destructor Moose::Meta::Method::Overridden Moose::Meta::Method::Augmented Moose::Meta::Role Moose::Meta::Role::Attribute Moose::Meta::Role::Method Moose::Meta::Role::Method::Required Moose::Meta::Role::Method::Conflicting Moose::Meta::Role::Composite Moose::Meta::Role::Application Moose::Meta::Role::Application::RoleSummation Moose::Meta::Role::Application::ToClass Moose::Meta::Role::Application::ToRole Moose::Meta::Role::Application::ToInstance ); $_->make_immutable( inline_constructor => 0, constructor_name => undef, # these are Class::MOP accessors, so they need inlining inline_accessors => 1 ) for grep { $_->is_mutable } map { $_->meta } qw( Moose::Meta::Method::Accessor Moose::Meta::Method::Delegation Moose::Meta::Mixin::AttributeCore ); 1; # ABSTRACT: A postmodern object system for Perl 5 __END__ =pod =head1 NAME Moose - A postmodern object system for Perl 5 =head1 VERSION version 2.1005 =head1 SYNOPSIS package Point; use Moose; # automatically turns on strict and warnings has 'x' => (is => 'rw', isa => 'Int'); has 'y' => (is => 'rw', isa => 'Int'); sub clear { my $self = shift; $self->x(0); $self->y(0); } package Point3D; use Moose; extends 'Point'; has 'z' => (is => 'rw', isa => 'Int'); after 'clear' => sub { my $self = shift; $self->z(0); }; =head1 DESCRIPTION Moose is an extension of the Perl 5 object system. The main goal of Moose is to make Perl 5 Object Oriented programming easier, more consistent, and less tedious. With Moose you can think more about what you want to do and less about the mechanics of OOP. Additionally, Moose is built on top of L, which is a metaclass system for Perl 5. This means that Moose not only makes building normal Perl 5 objects better, but it provides the power of metaclass programming as well. =head2 New to Moose? If you're new to Moose, the best place to start is the L docs, followed by the L. The intro will show you what Moose is, and how it makes Perl 5 OO better. The cookbook recipes on Moose basics will get you up to speed with many of Moose's features quickly. Once you have an idea of what Moose can do, you can use the API documentation to get more detail on features which interest you. =head2 Moose Extensions The C namespace is the official place to find Moose extensions. These extensions can be found on the CPAN. The easiest way to find them is to search for them (L), or to examine L which aims to keep an up-to-date, easily installable list of Moose extensions. =head1 TRANSLATIONS Much of the Moose documentation has been translated into other languages. =over 4 =item Japanese Japanese docs can be found at L. The source POD files can be found in GitHub: L =back =head1 BUILDING CLASSES WITH MOOSE Moose makes every attempt to provide as much convenience as possible during class construction/definition, but still stay out of your way if you want it to. Here are a few items to note when building classes with Moose. When you C, Moose will set the class's parent class to L, I the class using Moose already has a parent class. In addition, specifying a parent with C will change the parent class. Moose will also manage all attributes (including inherited ones) that are defined with C. And (assuming you call C, which is inherited from L) this includes properly initializing all instance slots, setting defaults where appropriate, and performing any type constraint checking or coercion. =head1 PROVIDED METHODS Moose provides a number of methods to all your classes, mostly through the inheritance of L. There is however, one exception. =over 4 =item B This is a method which provides access to the current class's metaclass. =back =head1 EXPORTED FUNCTIONS Moose will export a number of functions into the class's namespace which may then be used to set up the class. These functions all work directly on the current class. =over 4 =item B This function will set the superclass(es) for the current class. If the parent classes are not yet loaded, then C tries to load them. This approach is recommended instead of C, because C actually Ces onto the class's C<@ISA>, whereas C will replace it. This is important to ensure that classes which do not have superclasses still properly inherit from L. Each superclass can be followed by a hash reference with options. Currently, only L<-version|Class::MOP/Class Loading Options> is recognized: extends 'My::Parent' => { -version => 0.01 }, 'My::OtherParent' => { -version => 0.03 }; An exception will be thrown if the version requirements are not satisfied. =item B This will apply a given set of C<@roles> to the local class. Like with C, each specified role can be followed by a hash reference with a L<-version|Class::MOP/Class Loading Options> option: with 'My::Role' => { -version => 0.32 }, 'My::Otherrole' => { -version => 0.23 }; The specified version requirements must be satisfied, otherwise an exception will be thrown. If your role takes options or arguments, they can be passed along in the hash reference as well. =item B %options> This will install an attribute of a given C<$name> into the current class. If the first parameter is an array reference, it will create an attribute for every C<$name> in the list. The C<%options> will be passed to the constructor for L (which inherits from L), so the full documentation for the valid options can be found there. These are the most commonly used options: =over 4 =item I 'rw'|'ro'> The I option accepts either I (for read/write) or I (for read only). These will create either a read/write accessor or a read-only accessor respectively, using the same name as the C<$name> of the attribute. If you need more control over how your accessors are named, you can use the L, L and L options inherited from L, however if you use those, you won't need the I option. =item I $type_name> The I option uses Moose's type constraint facilities to set up runtime type checking for this attribute. Moose will perform the checks during class construction, and within any accessors. The C<$type_name> argument must be a string. The string may be either a class name or a type defined using Moose's type definition features. (Refer to L for information on how to define a new type, and how to retrieve type meta-data). =item I (1|0)> This will attempt to use coercion with the supplied type constraint to change the value passed into any accessors or constructors. You B supply a type constraint, and that type constraint B define a coercion. See L for an example. =item I $role_name> This will accept the name of a role which the value stored in this attribute is expected to have consumed. =item I (1|0)> This marks the attribute as being required. This means a value must be supplied during class construction, I the attribute must be lazy and have either a default or a builder. Note that c does not say anything about the attribute's value, which can be C. =item I (1|0)> This will tell the class to store the value of this attribute as a weakened reference. If an attribute is a weakened reference, it B also be coerced. Note that when a weak ref expires, the attribute's value becomes undefined, and is still considered to be set for purposes of predicate, default, etc. =item I (1|0)> This will tell the class to not create this slot until absolutely necessary. If an attribute is marked as lazy it B have a default or builder supplied. =item I $code> The I option is a CODE reference which will be called after the value of the attribute is set. The CODE ref is passed the instance itself, the updated value, and the original value if the attribute was already set. You B have a trigger on a read-only attribute. B Triggers will only fire when you B to the attribute, either in the constructor, or using the writer. Default and built values will B cause the trigger to be fired. =item I ARRAY | HASH | REGEXP | ROLE | ROLETYPE | DUCKTYPE | CODE> The I option provides Moose classes with automated delegation features. This is a pretty complex and powerful option. It accepts many different option formats, each with its own benefits and drawbacks. B The class being delegated to does not need to be a Moose based class, which is why this feature is especially useful when wrapping non-Moose classes. All I option formats share the following traits: You cannot override a locally defined method with a delegated method; an exception will be thrown if you try. That is to say, if you define C in your class, you cannot override it with a delegated C. This is almost never something you would want to do, and if it is, you should do it by hand and not use Moose. You cannot override any of the methods found in Moose::Object, or the C and C methods. These will not throw an exception, but will silently move on to the next method in the list. My reasoning for this is that you would almost never want to do this, since it usually breaks your class. As with overriding locally defined methods, if you do want to do this, you should do it manually, not with Moose. You do not I to have a reader (or accessor) for the attribute in order to delegate to it. Moose will create a means of accessing the value for you, however this will be several times B efficient then if you had given the attribute a reader (or accessor) to use. Below is the documentation for each option format: =over 4 =item C This is the most common usage for I. You basically pass a list of method names to be delegated, and Moose will install a delegation method for each one. =item C This is the second most common usage for I. Instead of a list of method names, you pass a HASH ref where each key is the method name you want installed locally, and its value is the name of the original method in the class being delegated to. This can be very useful for recursive classes like trees. Here is a quick example (soon to be expanded into a Moose::Cookbook recipe): package Tree; use Moose; has 'node' => (is => 'rw', isa => 'Any'); has 'children' => ( is => 'ro', isa => 'ArrayRef', default => sub { [] } ); has 'parent' => ( is => 'rw', isa => 'Tree', weak_ref => 1, handles => { parent_node => 'node', siblings => 'children', } ); In this example, the Tree package gets C and C methods, which delegate to the C and C methods (respectively) of the Tree instance stored in the C slot. You may also use an array reference to curry arguments to the original method. has 'thing' => ( ... handles => { set_foo => [ set => 'foo' ] }, ); # $self->set_foo(...) calls $self->thing->set('foo', ...) The first element of the array reference is the original method name, and the rest is a list of curried arguments. =item C The regexp option works very similar to the ARRAY option, except that it builds the list of methods for you. It starts by collecting all possible methods of the class being delegated to, then filters that list using the regexp supplied here. B An I option is required when using the regexp option format. This is so that we can determine (at compile time) the method list from the class. Without an I this is just not possible. =item C or C With the role option, you specify the name of a role or a L whose "interface" then becomes the list of methods to handle. The "interface" can be defined as; the methods of the role and any required methods of the role. It should be noted that this does B include any method modifiers or generated attribute methods (which is consistent with role composition). =item C With the duck type option, you pass a duck type object whose "interface" then becomes the list of methods to handle. The "interface" can be defined as the list of methods passed to C to create a duck type object. For more information on C please check L. =item C This is the option to use when you really want to do something funky. You should only use it if you really know what you are doing, as it involves manual metaclass twiddling. This takes a code reference, which should expect two arguments. The first is the attribute meta-object this I is attached to. The second is the metaclass of the class being delegated to. It expects you to return a hash (not a HASH ref) of the methods you want mapped. =back =item I [ @role_names ]> This tells Moose to take the list of C<@role_names> and apply them to the attribute meta-object. Custom attribute metaclass traits are useful for extending the capabilities of the I keyword: they are the simplest way to extend the MOP, but they are still a fairly advanced topic and too much to cover here. See L for details on how a trait name is resolved to a role name. Also see L for a metaclass trait example. =item I => Str The value of this key is the name of the method that will be called to obtain the value used to initialize the attribute. See the L and/or L for more information. =item I => SCALAR | CODE The value of this key is the default value which will initialize the attribute. NOTE: If the value is a simple scalar (string or number), then it can be just passed as is. However, if you wish to initialize it with a HASH or ARRAY ref, then you need to wrap that inside a CODE reference. See the L for more information. =item I => Str Creates a method allowing you to clear the value. See the L for more information. =item I => Str Creates a method to perform a basic test to see if a value has been set in the attribute. See the L for more information. Note that the predicate will return true even for a C attribute whose value has expired. =item I => $string An arbitrary string that can be retrieved later by calling C<< $attr->documentation >>. =back =item B %options> This is variation on the normal attribute creator C which allows you to clone and extend an attribute from a superclass or from a role. Here is an example of the superclass usage: package Foo; use Moose; has 'message' => ( is => 'rw', isa => 'Str', default => 'Hello, I am a Foo' ); package My::Foo; use Moose; extends 'Foo'; has '+message' => (default => 'Hello I am My::Foo'); What is happening here is that B is cloning the C attribute from its parent class B, retaining the C 'rw'> and C 'Str'> characteristics, but changing the value in C. Here is another example, but within the context of a role: package Foo::Role; use Moose::Role; has 'message' => ( is => 'rw', isa => 'Str', default => 'Hello, I am a Foo' ); package My::Foo; use Moose; with 'Foo::Role'; has '+message' => (default => 'Hello I am My::Foo'); In this case, we are basically taking the attribute which the role supplied and altering it within the bounds of this feature. Note that you can only extend an attribute from either a superclass or a role, you cannot extend an attribute in a role that composes over an attribute from another role. Aside from where the attributes come from (one from superclass, the other from a role), this feature works exactly the same. This feature is restricted somewhat, so as to try and force at least I sanity into it. Most options work the same, but there are some exceptions: =over 4 =item I =item I =item I =item I =item I These options can be added, but cannot override a superclass definition. =item I You are allowed to B additional traits to the C definition. These traits will be composed into the attribute, but preexisting traits B overridden, or removed. =back =item B sub { ... }> =item B sub { ... }> =item B sub { ... }> These three items are syntactic sugar for the before, after, and around method modifier features that L provides. More information on these may be found in L and the L. =item B An C method is a way of explicitly saying "I am overriding this method from my superclass". You can call C within this method, and it will work as expected. The same thing I be accomplished with a normal method call and the C pseudo-package; it is really your choice. =item B The keyword C is a no-op when called outside of an C method. In the context of an C method, it will call the next most appropriate superclass method with the same arguments as the original method. =item B An C method, is a way of explicitly saying "I am augmenting this method from my superclass". Once again, the details of how C and C work is best described in the L. =item B The keyword C, much like C, is a no-op outside of the context of an C method. You can think of C as being the inverse of C; the details of how C and C work is best described in the L. =item B This is the C function. It is highly recommended that this is used instead of C anywhere you need to test for an object's class name. =item B This is the C function, and exported here for historical reasons. =back =head1 METACLASS When you use Moose, you can specify traits which will be applied to your metaclass: use Moose -traits => 'My::Trait'; This is very similar to the attribute traits feature. When you do this, your class's C object will have the specified traits applied to it. See L for more details. =head2 Metaclass and Trait Name Resolution By default, when given a trait name, Moose simply tries to load a class of the same name. If such a class does not exist, it then looks for a class matching B. The C<$type> variable here will be one of B or B, depending on what the trait is being applied to. If a class with this long name exists, Moose checks to see if it has the method C. This method is expected to return the I class name of the trait. If there is no C method, it will fall back to using B as the trait name. The lookup method for metaclasses is the same, except that it looks for a class matching B. If all this is confusing, take a look at L, which demonstrates how to create an attribute trait. =head1 UNIMPORTING FUNCTIONS =head2 B Moose offers a way to remove the keywords it exports, through the C method. You simply have to say C at the bottom of your code for this to work. Here is an example: package Person; use Moose; has 'first_name' => (is => 'rw', isa => 'Str'); has 'last_name' => (is => 'rw', isa => 'Str'); sub full_name { my $self = shift; $self->first_name . ' ' . $self->last_name } no Moose; # keywords are removed from the Person package =head1 EXTENDING AND EMBEDDING MOOSE To learn more about extending Moose, we recommend checking out the "Extending" recipes in the L, starting with L, which provides an overview of all the different ways you might extend Moose. L and L are the modules which provide the majority of the extension functionality, so reading their documentation should also be helpful. =head2 The MooseX:: namespace Generally if you're writing an extension I Moose itself you'll want to put your extension in the C namespace. This namespace is specifically for extensions that make Moose better or different in some fundamental way. It is traditionally B for a package that just happens to use Moose. This namespace follows from the examples of the C and C namespaces that perform the same function for C and C respectively. =head1 METACLASS COMPATIBILITY AND MOOSE Metaclass compatibility is a thorny subject. You should start by reading the "About Metaclass compatibility" section in the C docs. Moose will attempt to resolve a few cases of metaclass incompatibility when you set the superclasses for a class, in addition to the cases that C handles. Moose tries to determine if the metaclasses only "differ by roles". This means that the parent and child's metaclass share a common ancestor in their respective hierarchies, and that the subclasses under the common ancestor are only different because of role applications. This case is actually fairly common when you mix and match various C modules, many of which apply roles to the metaclass. If the parent and child do differ by roles, Moose replaces the metaclass in the child with a newly created metaclass. This metaclass is a subclass of the parent's metaclass which does all of the roles that the child's metaclass did before being replaced. Effectively, this means the new metaclass does all of the roles done by both the parent's and child's original metaclasses. Ultimately, this is all transparent to you except in the case of an unresolvable conflict. =head1 CAVEATS =over 4 =item * It should be noted that C and C B be used in the same method. However, they may be combined within the same class hierarchy; see F for an example. The reason for this is that C is only valid within a method with the C modifier, and C will never be valid within an C method. In fact, C will skip over any C methods when searching for its appropriate C. This might seem like a restriction, but I am of the opinion that keeping these two features separate (yet interoperable) actually makes them easy to use, since their behavior is then easier to predict. Time will tell whether I am right or not (UPDATE: so far so good). =back =head1 GETTING HELP We offer both a mailing list and a very active IRC channel. The mailing list is L. You must be subscribed to send a message. To subscribe, send an empty message to L You can also visit us at C<#moose> on L This channel is quite active, and questions at all levels (on Moose-related topics ;) are welcome. =head1 WHAT DOES MOOSE STAND FOR? Moose doesn't stand for one thing in particular, however, if you want, here are a few of our favorites. Feel free to contribute more! =over 4 =item * Make Other Object Systems Envious =item * Makes Object Orientation So Easy =item * Makes Object Orientation Spiffy- Er (sorry ingy) =item * Most Other Object Systems Emasculate =item * Moose Often Ovulate Sorta Early =item * Moose Offers Often Super Extensions =item * Meta Object Obligates Salivary Excitation =item * Meta Object Orientation Syntax Extensions =back =head1 ACKNOWLEDGEMENTS =over 4 =item I blame Sam Vilain for introducing me to the insanity that is meta-models. =item I blame Audrey Tang for then encouraging my meta-model habit in #perl6. =item Without Yuval "nothingmuch" Kogman this module would not be possible, and it certainly wouldn't have this name ;P =item The basis of the TypeContraints module was Rob Kinyon's idea originally, I just ran with it. =item Thanks to mst & chansen and the whole #moose posse for all the early ideas/feature-requests/encouragement/bug-finding. =item Thanks to David "Theory" Wheeler for meta-discussions and spelling fixes. =back =head1 SEE ALSO =over 4 =item L This is the official web home of Moose. It contains links to our public git repository, as well as links to a number of talks and articles on Moose and Moose related technologies. =item the L This is an introduction to Moose which covers most of the basics. =item Modern Perl, by chromatic This is an introduction to modern Perl programming, which includes a section on Moose. It is available in print and as a free download from L. =item The Moose is flying, a tutorial by Randal Schwartz Part 1 - L Part 2 - L =item Several Moose extension modules in the C namespace. See L for extensions. =back =head2 Books =over 4 =item The Art of the MetaObject Protocol I mention this in the L docs too, as this book was critical in the development of both modules and is highly recommended. =back =head2 Papers =over 4 =item L This paper (suggested by lbr on #moose) was what lead to the implementation of the C/C and C/C features. If you really want to understand them, I suggest you read this. =back =head1 BUGS All complex software has bugs lurking in it, and this module is no exception. Please report any bugs to C, or through the web interface at L. You can also discuss feature requests or possible bugs on the Moose mailing list (moose@perl.org) or on IRC at L. =head1 FEATURE REQUESTS We are very strict about what features we add to the Moose core, especially the user-visible features. Instead we have made sure that the underlying meta-system of Moose is as extensible as possible so that you can add your own features easily. That said, occasionally there is a feature needed in the meta-system to support your planned extension, in which case you should either email the mailing list (moose@perl.org) or join us on IRC at L to discuss. The L has more detail about how and when you can contribute. =head1 CABAL There are only a few people with the rights to release a new version of Moose. The Moose Cabal are the people to go to with questions regarding the wider purview of Moose. They help maintain not just the code but the community as well. Stevan (stevan) Little Estevan@iinteractive.comE Jesse (doy) Luehrs Edoy at tozt dot netE Yuval (nothingmuch) Kogman Shawn (sartak) Moore Esartak@bestpractical.comE Hans Dieter (confound) Pearcey Ehdp@pobox.comE Chris (perigrin) Prather Florian Ragwitz Erafl@debian.orgE Dave (autarch) Rolsky Eautarch@urth.orgE Karen (ether) Etheridge Eether@cpan.orgE =head1 CONTRIBUTORS Moose is a community project, and as such, involves the work of many, many members of the community beyond just the members in the cabal. In particular: Dave (autarch) Rolsky wrote most of the documentation in L. John (jgoulah) Goulah wrote L. Jess (castaway) Robinson wrote L. Aran (bluefeet) Clary Deltac wrote L. Anders (Debolaz) Nor Berle contributed L and L. Also, the code in L is based on code from the L distribution, which had contributions from: Chris (perigrin) Prather Cory (gphat) Watson Evan Carroll Florian (rafl) Ragwitz Jason May Jay Hannah Jesse (doy) Luehrs Paul (frodwith) Driver Robert (rlb3) Boone Robert Buels Robert (phaylon) Sedlacek Shawn (Sartak) Moore Stevan Little Tom (dec) Lanyon Yuval Kogman Finally, these people also contributed various tests, bug fixes, documentation, and features to the Moose codebase: Aankhen Adam (Alias) Kennedy Christian (chansen) Hansen Cory (gphat) Watson Dylan Hardison (doc fixes) Eric (ewilhelm) Wilhelm Evan Carroll Guillermo (groditi) Roditi Jason May Jay Hannah Jonathan (jrockway) Rockway Matt (mst) Trout Nathan (kolibrie) Gray Paul (frodwith) Driver Piotr (dexter) Roszatycki Robert Buels Robert (phaylon) Sedlacek Robert (rlb3) Boone Sam (mugwump) Vilain Scott (konobi) McWhirter Shlomi (rindolf) Fish Tom (dec) Lanyon Wallace (wreis) Reis ... and many other #moose folks =head1 AUTHOR Moose is maintained by the Moose Cabal, along with the help of many contributors. See L and L for details. =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2013 by Infinity Interactive, Inc.. This is free software; you can redistribute it and/or modify it under the same terms as the Perl 5 programming language system itself. =cut t000755000767000024 012200352344 12437 5ustar00etherstaff000000000000Moose-2.1005000_load.t100644000767000024 15312200352344 14241 0ustar00etherstaff000000000000Moose-2.1005/t#!/usr/bin/perl use strict; use warnings; use Test::More; BEGIN { use_ok('Moose'); } done_testing; lib000755000767000024 012200352344 13205 5ustar00etherstaff000000000000Moose-2.1005/tBar.pm100600000767000024 20112200352344 14350 0ustar00etherstaff000000000000Moose-2.1005/t/lib package Bar; use Moose; use Moose::Util::TypeConstraints; type Baz => where { 1 }; subtype Bling => as Baz => where { 1 }; 1;Foo.pm100600000767000024 7012200352344 14353 0ustar00etherstaff000000000000Moose-2.1005/t/lib package Foo; use Moose; has 'bar' => (is => 'rw'); 1;Method.xs100644000767000024 75212200352344 14546 0ustar00etherstaff000000000000Moose-2.1005/xs#include "mop.h" MODULE = Class::MOP::Method PACKAGE = Class::MOP::Method PROTOTYPES: DISABLE BOOT: INSTALL_SIMPLE_READER(Method, name); INSTALL_SIMPLE_READER(Method, package_name); INSTALL_SIMPLE_READER(Method, body); bool is_stub(self) SV *self PREINIT: CV *const body = (CV *)SvRV( HeVAL( hv_fetch_ent((HV *)SvRV(self), KEY_FOR(body), 0, HASH_FOR(body)) ) ); CODE: RETVAL = !( CvISXSUB(body) || CvROOT(body) ); OUTPUT: RETVAL cmop000755000767000024 012200352344 13375 5ustar00etherstaff000000000000Moose-2.1005/tload.t100644000767000024 1456412200352344 14673 0ustar00etherstaff000000000000Moose-2.1005/t/cmopuse strict; use warnings; # for instance, App::ForkProve my $preloaded; BEGIN { $preloaded = exists $INC{'Class/MOP.pm'} } use Test::More; use Class::Load qw(is_class_loaded); BEGIN { use_ok('Class::MOP'); use_ok('Class::MOP::Mixin'); use_ok('Class::MOP::Mixin::AttributeCore'); use_ok('Class::MOP::Mixin::HasAttributes'); use_ok('Class::MOP::Mixin::HasMethods'); use_ok('Class::MOP::Package'); use_ok('Class::MOP::Module'); use_ok('Class::MOP::Class'); use_ok('Class::MOP::Class::Immutable::Trait'); use_ok('Class::MOP::Method'); use_ok('Class::MOP::Method'); use_ok('Class::MOP::Method::Wrapped'); use_ok('Class::MOP::Method::Inlined'); use_ok('Class::MOP::Method::Generated'); use_ok('Class::MOP::Method::Accessor'); use_ok('Class::MOP::Method::Constructor'); use_ok('Class::MOP::Method::Meta'); use_ok('Class::MOP::Method::Overload'); use_ok('Class::MOP::Instance'); use_ok('Class::MOP::Object'); } # make sure we are tracking metaclasses correctly my %METAS = ( 'Class::MOP::Attribute' => Class::MOP::Attribute->meta, 'Class::MOP::Method::Inlined' => Class::MOP::Method::Inlined->meta, 'Class::MOP::Method::Generated' => Class::MOP::Method::Generated->meta, 'Class::MOP::Method::Accessor' => Class::MOP::Method::Accessor->meta, 'Class::MOP::Method::Constructor' => Class::MOP::Method::Constructor->meta, 'Class::MOP::Method::Meta' => Class::MOP::Method::Meta->meta, 'Class::MOP::Method::Overload' => Class::MOP::Method::Overload->meta, 'Class::MOP::Mixin' => Class::MOP::Mixin->meta, 'Class::MOP::Mixin::AttributeCore' => Class::MOP::Mixin::AttributeCore->meta, 'Class::MOP::Mixin::HasAttributes' => Class::MOP::Mixin::HasAttributes->meta, 'Class::MOP::Mixin::HasMethods' => Class::MOP::Mixin::HasMethods->meta, 'Class::MOP::Package' => Class::MOP::Package->meta, 'Class::MOP::Module' => Class::MOP::Module->meta, 'Class::MOP::Class' => Class::MOP::Class->meta, 'Class::MOP::Method' => Class::MOP::Method->meta, 'Class::MOP::Method::Wrapped' => Class::MOP::Method::Wrapped->meta, 'Class::MOP::Instance' => Class::MOP::Instance->meta, 'Class::MOP::Object' => Class::MOP::Object->meta, 'Class::MOP::Class::Immutable::Trait' => Class::MOP::class_of('Class::MOP::Class::Immutable::Trait'), 'Class::MOP::Class::Immutable::Class::MOP::Class' => Class::MOP::Class::Immutable::Class::MOP::Class->meta, 'UNIVERSAL' => Class::MOP::class_of('UNIVERSAL'), ); ok( is_class_loaded($_), '... ' . $_ . ' is loaded' ) for keys %METAS; # The trait shouldn't be made immutable, it doesn't actually do anything, and # it doesn't even matter because it's not a class that will be # instantiated. Making UNIVERSAL immutable just seems like a bad idea. my %expect_mutable = map { $_ => 1 } qw( Class::MOP::Class::Immutable::Trait UNIVERSAL ); for my $meta (values %METAS) { if ( $expect_mutable{$meta->name} ) { ok( $meta->is_mutable(), '... ' . $meta->name . ' is mutable' ); } else { ok( $meta->is_immutable(), '... ' . $meta->name . ' is immutable' ); } } SKIP: { skip "this list may be incorrect if we preloaded things", 3 if $preloaded; is_deeply( {Class::MOP::get_all_metaclasses}, \%METAS, '... got all the metaclasses' ); is_deeply( [ sort { $a->name cmp $b->name } Class::MOP::get_all_metaclass_instances ], [ Class::MOP::Attribute->meta, Class::MOP::Class->meta, Class::MOP::Class::Immutable::Class::MOP::Class->meta, Class::MOP::class_of('Class::MOP::Class::Immutable::Trait'), Class::MOP::Instance->meta, Class::MOP::Method->meta, Class::MOP::Method::Accessor->meta, Class::MOP::Method::Constructor->meta, Class::MOP::Method::Generated->meta, Class::MOP::Method::Inlined->meta, Class::MOP::Method::Meta->meta, Class::MOP::Method::Overload->meta, Class::MOP::Method::Wrapped->meta, Class::MOP::Mixin->meta, Class::MOP::Mixin::AttributeCore->meta, Class::MOP::Mixin::HasAttributes->meta, Class::MOP::Mixin::HasMethods->meta, Class::MOP::Module->meta, Class::MOP::Object->meta, Class::MOP::Package->meta, Class::MOP::class_of('UNIVERSAL'), ], '... got all the metaclass instances' ); is_deeply( [ sort { $a cmp $b } Class::MOP::get_all_metaclass_names() ], [ sort qw/ Class::MOP::Attribute Class::MOP::Class Class::MOP::Class::Immutable::Class::MOP::Class Class::MOP::Class::Immutable::Trait Class::MOP::Mixin Class::MOP::Mixin::AttributeCore Class::MOP::Mixin::HasAttributes Class::MOP::Mixin::HasMethods Class::MOP::Instance Class::MOP::Method Class::MOP::Method::Accessor Class::MOP::Method::Constructor Class::MOP::Method::Generated Class::MOP::Method::Inlined Class::MOP::Method::Wrapped Class::MOP::Method::Meta Class::MOP::Method::Overload Class::MOP::Module Class::MOP::Object Class::MOP::Package UNIVERSAL /, ], '... got all the metaclass names' ); } # testing the meta-circularity of the system is( Class::MOP::Class->meta->meta, Class::MOP::Class->meta->meta->meta, '... Class::MOP::Class->meta->meta == Class::MOP::Class->meta->meta->meta' ); is( Class::MOP::Class->meta->meta->meta, Class::MOP::Class->meta->meta->meta->meta, '... Class::MOP::Class->meta->meta->meta == Class::MOP::Class->meta->meta->meta->meta' ); is( Class::MOP::Class->meta->meta, Class::MOP::Class->meta->meta->meta->meta, '... Class::MOP::Class->meta->meta == Class::MOP::Class->meta->meta->meta->meta' ); is( Class::MOP::Class->meta->meta, Class::MOP::Class->meta->meta->meta->meta->meta, '... Class::MOP::Class->meta->meta == Class::MOP::Class->meta->meta->meta->meta->meta' ); isa_ok(Class::MOP::Class->meta, 'Class::MOP::Class'); done_testing; Inlined.xs100644000767000024 27712200352344 14712 0ustar00etherstaff000000000000Moose-2.1005/xs#include "mop.h" MODULE = Class::MOP::Method::Inlined PACKAGE = Class::MOP::Method::Inlined PROTOTYPES: DISABLE BOOT: INSTALL_SIMPLE_READER(Method::Inlined, _expected_method_class); Package.xs100644000767000024 24712200352344 14660 0ustar00etherstaff000000000000Moose-2.1005/xs#include "mop.h" MODULE = Class::MOP::Package PACKAGE = Class::MOP::Package PROTOTYPES: DISABLE BOOT: INSTALL_SIMPLE_READER_WITH_KEY(Package, name, package); basic.t100644000767000024 434512200352344 15011 0ustar00etherstaff000000000000Moose-2.1005/t/cmopuse strict; use warnings; use Test::More; use Test::Fatal; use Class::MOP; use Class::MOP::Class; { package Foo; use metaclass; our $VERSION = '0.01'; package Bar; our @ISA = ('Foo'); our $AUTHORITY = 'cpan:JRANDOM'; } my $Foo = Foo->meta; isa_ok($Foo, 'Class::MOP::Class'); my $Bar = Bar->meta; isa_ok($Bar, 'Class::MOP::Class'); is($Foo->name, 'Foo', '... Foo->name == Foo'); is($Bar->name, 'Bar', '... Bar->name == Bar'); is($Foo->version, '0.01', '... Foo->version == 0.01'); is($Bar->version, undef, '... Bar->version == undef'); is($Foo->authority, undef, '... Foo->authority == undef'); is($Bar->authority, 'cpan:JRANDOM', '... Bar->authority == cpan:JRANDOM'); is($Foo->identifier, 'Foo-0.01', '... Foo->identifier == Foo-0.01'); is($Bar->identifier, 'Bar-cpan:JRANDOM', '... Bar->identifier == Bar-cpan:JRANDOM'); is_deeply([$Foo->superclasses], [], '... Foo has no superclasses'); is_deeply([$Bar->superclasses], ['Foo'], '... Bar->superclasses == (Foo)'); $Foo->superclasses('UNIVERSAL'); is_deeply([$Foo->superclasses], ['UNIVERSAL'], '... Foo->superclasses == (UNIVERSAL) now'); is_deeply( [ $Foo->class_precedence_list ], [ 'Foo', 'UNIVERSAL' ], '... Foo->class_precedence_list == (Foo, UNIVERSAL)'); is_deeply( [ $Bar->class_precedence_list ], [ 'Bar', 'Foo', 'UNIVERSAL' ], '... Bar->class_precedence_list == (Bar, Foo, UNIVERSAL)'); # create a class using Class::MOP::Class ... my $Baz = Class::MOP::Class->create( 'Baz' => ( version => '0.10', authority => 'cpan:YOMAMA', superclasses => [ 'Bar' ] )); isa_ok($Baz, 'Class::MOP::Class'); is(Baz->meta, $Baz, '... our metaclasses are singletons'); is($Baz->name, 'Baz', '... Baz->name == Baz'); is($Baz->version, '0.10', '... Baz->version == 0.10'); is($Baz->authority, 'cpan:YOMAMA', '... Baz->authority == YOMAMA'); is($Baz->identifier, 'Baz-0.10-cpan:YOMAMA', '... Baz->identifier == Baz-0.10-cpan:YOMAMA'); is_deeply([$Baz->superclasses], ['Bar'], '... Baz->superclasses == (Bar)'); is_deeply( [ $Baz->class_precedence_list ], [ 'Baz', 'Bar', 'Foo', 'UNIVERSAL' ], '... Baz->class_precedence_list == (Baz, Bar, Foo, UNIVERSAL)'); done_testing; magic.t100644000767000024 313612200352344 15005 0ustar00etherstaff000000000000Moose-2.1005/t/cmop# Testing magical scalars (using tied scalar) # Note that XSUBs do not handle magical scalars automatically. use strict; use warnings; use Test::More; use Test::Fatal; use Class::Load qw( is_class_loaded load_class ); use Class::MOP; use Tie::Scalar; { package Foo; use metaclass; Foo->meta->add_attribute('bar' => reader => 'get_bar', writer => 'set_bar', ); Foo->meta->add_attribute('baz' => accessor => 'baz', ); Foo->meta->make_immutable(); } { tie my $foo, 'Tie::StdScalar', Foo->new(bar => 100, baz => 200); is $foo->get_bar, 100, 'reader with tied self'; is $foo->baz, 200, 'accessor/r with tied self'; $foo->set_bar(300); $foo->baz(400); is $foo->get_bar, 300, 'writer with tied self'; is $foo->baz, 400, 'accessor/w with tied self'; } { my $foo = Foo->new(); tie my $value, 'Tie::StdScalar', 42; $foo->set_bar($value); $foo->baz($value); is $foo->get_bar, 42, 'reader/writer with tied value'; is $foo->baz, 42, 'accessor with tied value'; } { my $x = tie my $value, 'Tie::StdScalar', 'Class::MOP'; is( exception { load_class($value) }, undef, 'load_class(tied scalar)' ); $value = undef; $x->STORE('Class::MOP'); # reset is( exception { ok is_class_loaded($value); }, undef, 'is_class_loaded(tied scalar)' ); $value = undef; $x->STORE(\&Class::MOP::get_code_info); # reset is( exception { is_deeply [Class::MOP::get_code_info($value)], [qw(Class::MOP get_code_info)], 'get_code_info(tied scalar)'; }, undef ); } done_testing; roles000755000767000024 012200352344 13563 5ustar00etherstaff000000000000Moose-2.1005/trole.t100644000767000024 1127612200352344 15100 0ustar00etherstaff000000000000Moose-2.1005/t/roles#!/usr/bin/perl use strict; use warnings; use Test::More; use Test::Fatal; =pod NOTE: Should we be testing here that the has & override are injecting their methods correctly? In other words, should 'has_method' return true for them? =cut { package FooRole; use Moose::Role; our $VERSION = '0.01'; has 'bar' => (is => 'rw', isa => 'Foo'); has 'baz' => (is => 'ro'); sub foo { 'FooRole::foo' } sub boo { 'FooRole::boo' } before 'boo' => sub { "FooRole::boo:before" }; after 'boo' => sub { "FooRole::boo:after1" }; after 'boo' => sub { "FooRole::boo:after2" }; around 'boo' => sub { "FooRole::boo:around" }; override 'bling' => sub { "FooRole::bling:override" }; override 'fling' => sub { "FooRole::fling:override" }; ::isnt( ::exception { extends() }, undef, '... extends() is not supported' ); ::isnt( ::exception { augment() }, undef, '... augment() is not supported' ); ::isnt( ::exception { inner() }, undef, '... inner() is not supported' ); no Moose::Role; } my $foo_role = FooRole->meta; isa_ok($foo_role, 'Moose::Meta::Role'); isa_ok($foo_role, 'Class::MOP::Module'); is($foo_role->name, 'FooRole', '... got the right name of FooRole'); is($foo_role->version, '0.01', '... got the right version of FooRole'); # methods ... ok($foo_role->has_method('foo'), '... FooRole has the foo method'); is($foo_role->get_method('foo')->body, \&FooRole::foo, '... FooRole got the foo method'); isa_ok($foo_role->get_method('foo'), 'Moose::Meta::Role::Method'); ok($foo_role->has_method('boo'), '... FooRole has the boo method'); is($foo_role->get_method('boo')->body, \&FooRole::boo, '... FooRole got the boo method'); isa_ok($foo_role->get_method('boo'), 'Moose::Meta::Role::Method'); is_deeply( [ sort $foo_role->get_method_list() ], [ 'boo', 'foo', 'meta' ], '... got the right method list'); ok(FooRole->can('foo'), "locally defined methods are still there"); ok(!FooRole->can('has'), "sugar was unimported"); # attributes ... is_deeply( [ sort $foo_role->get_attribute_list() ], [ 'bar', 'baz' ], '... got the right attribute list'); ok($foo_role->has_attribute('bar'), '... FooRole does have the bar attribute'); my $bar_attr = $foo_role->get_attribute('bar'); is($bar_attr->{is}, 'rw', 'bar attribute is rw'); is($bar_attr->{isa}, 'Foo', 'bar attribute isa Foo'); is(ref($bar_attr->{definition_context}), 'HASH', 'bar\'s definition context is a hash'); is($bar_attr->{definition_context}->{package}, 'FooRole', 'bar was defined in FooRole'); ok($foo_role->has_attribute('baz'), '... FooRole does have the baz attribute'); my $baz_attr = $foo_role->get_attribute('baz'); is($baz_attr->{is}, 'ro', 'baz attribute is ro'); is(ref($baz_attr->{definition_context}), 'HASH', 'bar\'s definition context is a hash'); is($baz_attr->{definition_context}->{package}, 'FooRole', 'baz was defined in FooRole'); # method modifiers ok($foo_role->has_before_method_modifiers('boo'), '... now we have a boo:before modifier'); is(($foo_role->get_before_method_modifiers('boo'))[0]->(), "FooRole::boo:before", '... got the right method back'); is_deeply( [ $foo_role->get_method_modifier_list('before') ], [ 'boo' ], '... got the right list of before method modifiers'); ok($foo_role->has_after_method_modifiers('boo'), '... now we have a boo:after modifier'); is(($foo_role->get_after_method_modifiers('boo'))[0]->(), "FooRole::boo:after1", '... got the right method back'); is(($foo_role->get_after_method_modifiers('boo'))[1]->(), "FooRole::boo:after2", '... got the right method back'); is_deeply( [ $foo_role->get_method_modifier_list('after') ], [ 'boo' ], '... got the right list of after method modifiers'); ok($foo_role->has_around_method_modifiers('boo'), '... now we have a boo:around modifier'); is(($foo_role->get_around_method_modifiers('boo'))[0]->(), "FooRole::boo:around", '... got the right method back'); is_deeply( [ $foo_role->get_method_modifier_list('around') ], [ 'boo' ], '... got the right list of around method modifiers'); ## overrides ok($foo_role->has_override_method_modifier('bling'), '... now we have a bling:override modifier'); is($foo_role->get_override_method_modifier('bling')->(), "FooRole::bling:override", '... got the right method back'); ok($foo_role->has_override_method_modifier('fling'), '... now we have a fling:override modifier'); is($foo_role->get_override_method_modifier('fling')->(), "FooRole::fling:override", '... got the right method back'); is_deeply( [ sort $foo_role->get_method_modifier_list('override') ], [ 'bling', 'fling' ], '... got the right list of override method modifiers'); done_testing; Instance.xs100644000767000024 25012200352344 15063 0ustar00etherstaff000000000000Moose-2.1005/xs#include "mop.h" MODULE = Class::MOP::Instance PACKAGE = Class::MOP::Instance PROTOTYPES: DISABLE BOOT: INSTALL_SIMPLE_READER(Instance, associated_metaclass); Overload.xs100644000767000024 26412200352344 15077 0ustar00etherstaff000000000000Moose-2.1005/xs#include "mop.h" MODULE = Class::MOP::Method::Overload PACKAGE = Class::MOP::Method::Overload PROTOTYPES: DISABLE BOOT: INSTALL_SIMPLE_READER(Method::Overload, operator); MMHelper.pm100644000767000024 244612200352344 15122 0ustar00etherstaff000000000000Moose-2.1005/incpackage MMHelper; use strict; use warnings; use Config; use Cwd qw( abs_path ); use File::Basename qw( dirname ); sub ccflags_dyn { my $is_dev = shift; my $ccflags = q<( $Config::Config{ccflags} || '' ) . ' -I.'>; $ccflags .= q< . ' -Wall -Wdeclaration-after-statement'> if $is_dev; return $ccflags; } sub ccflags_static { my $is_dev = shift; return eval(ccflags_dyn($is_dev)); } sub mm_args { my ( @object, %xs ); for my $xs ( glob "xs/*.xs" ) { ( my $c = $xs ) =~ s/\.xs$/.c/i; ( my $o = $xs ) =~ s/\.xs$/\$(OBJ_EXT)/i; $xs{$xs} = $c; push @object, $o; } for my $c ( glob "*.c" ) { ( my $o = $c ) =~ s/\.c$/\$(OBJ_EXT)/i; push @object, $o; } return ( clean => { FILES => join( q{ }, @object ) }, OBJECT => join( q{ }, @object ), XS => \%xs, ); } sub my_package_subs { return <<'EOP'; { package MY; use Config; sub const_cccmd { my $ret = shift->SUPER::const_cccmd(@_); return q{} unless $ret; if ($Config{cc} =~ /^cl\b/i) { warn 'you are using MSVC... my condolences.'; $ret .= ' /Fo$@'; } else { $ret .= ' -o $@'; } return $ret; } sub postamble { return <<'EOF'; $(OBJECT) : mop.h EOF } } EOP } 1; MyInline.pm100644000767000024 552212200352344 15173 0ustar00etherstaff000000000000Moose-2.1005/incpackage MyInline; use strict; use warnings; { package My::Extract; use base 'Test::Inline::Extract'; use List::Util qw( first ); # This extracts the SYNOPSIS in addition to code specifically # marked for testing my $search = qr/ (?:^|\n) # After the beginning of the string, or a newline ( # ... start capturing # EITHER package\s+ # A package [^\W\d]\w*(?:(?:\'|::)[^\W\d]\w*)* # ... with a name \s*; # And a statement terminator | =head1[ \t]+SYNOPSIS\n .*? (?=\n=) | # OR =for[ \t]+example[ \t]+begin\n # ... when we find a =for example begin .*? # ... and keep capturing \n=for[ \t]+example[ \t]+end\s*? # ... until the =for example end (?:\n|$) # ... at the end of file or a newline | # OR =begin[ \t]+(?:test|testing)(?:-SETUP)? # ... when we find a =begin test or testing .*? # ... and keep capturing \n=end[ \t]+(?:test|testing)(?:-SETUP)? # ... until an =end tag .*? (?:\n|$) # ... at the end of file or a newline ) # ... and stop capturing /isx; sub _elements { my $self = shift; my @elements = (); while ( $self->{source} =~ m/$search/go ) { my $elt = $1; # A hack to turn the SYNOPSIS into something Test::Inline # doesn't barf on if ( $elt =~ s/=head1[ \t]+SYNOPSIS/=begin testing-SETUP\n\n{/ ) { $elt .= "}\n\n=end testing-SETUP"; } # It seems like search.cpan doesn't like a name with # spaces after =begin. bleah, what a mess. $elt =~ s/testing-SETUP/testing SETUP/g; push @elements, $elt; } # If we have just one element it's a SYNOPSIS, so there's no # tests. return unless @elements > 2; if ( @elements && $self->{source} =~ /=head1 NAME\n\n(Moose::Cookbook\S+)/ ) { unshift @elements, 'package ' . $1 . ';'; } ( first {/^=/} @elements ) ? \@elements : ''; } } { package My::Content; use base 'Test::Inline::Content::Default'; sub process { my $self = shift; my $base = $self->SUPER::process(@_); $base =~ s/(\$\| = 1;)/use Test::Fatal;\n$1/; return $base; } } 1; method.t100644000767000024 1330612200352344 15225 0ustar00etherstaff000000000000Moose-2.1005/t/cmopuse strict; use warnings; use Test::More; use Test::Fatal; use Class::MOP; use Class::MOP::Method; my $method = Class::MOP::Method->wrap( sub {1}, package_name => 'main', name => '__ANON__', ); is( $method->meta, Class::MOP::Method->meta, '... instance and class both lead to the same meta' ); is( $method->package_name, 'main', '... our package is main::' ); is( $method->name, '__ANON__', '... our sub name is __ANON__' ); is( $method->fully_qualified_name, 'main::__ANON__', '... our subs full name is main::__ANON__' ); is( $method->original_method, undef, '... no original_method ' ); is( $method->original_package_name, 'main', '... the original_package_name is the same as package_name' ); is( $method->original_name, '__ANON__', '... the original_name is the same as name' ); is( $method->original_fully_qualified_name, 'main::__ANON__', '... the original_fully_qualified_name is the same as fully_qualified_name' ); ok( !$method->is_stub, '... the method is not a stub' ); isnt( exception { Class::MOP::Method->wrap }, undef, q{... can't call wrap() without some code} ); isnt( exception { Class::MOP::Method->wrap( [] ) }, undef, q{... can't call wrap() without some code} ); isnt( exception { Class::MOP::Method->wrap( bless {} => 'Fail' ) }, undef, q{... can't call wrap() without some code} ); isnt( exception { Class::MOP::Method->name }, undef, q{... can't call name() as a class method} ); isnt( exception { Class::MOP::Method->body }, undef, q{... can't call body() as a class method} ); isnt( exception { Class::MOP::Method->package_name }, undef, q{... can't call package_name() as a class method} ); isnt( exception { Class::MOP::Method->fully_qualified_name }, undef, q{... can't call fully_qualified_name() as a class method} ); my $meta = Class::MOP::Method->meta; isa_ok( $meta, 'Class::MOP::Class' ); foreach my $method_name ( qw( wrap package_name name ) ) { ok( $meta->has_method($method_name), '... Class::MOP::Method->has_method(' . $method_name . ')' ); my $method = $meta->get_method($method_name); is( $method->package_name, 'Class::MOP::Method', '... our package is Class::MOP::Method' ); is( $method->name, $method_name, '... our sub name is "' . $method_name . '"' ); } isnt( exception { Class::MOP::Method->wrap(); }, undef, '... bad args for &wrap' ); isnt( exception { Class::MOP::Method->wrap('Fail'); }, undef, '... bad args for &wrap' ); isnt( exception { Class::MOP::Method->wrap( [] ); }, undef, '... bad args for &wrap' ); isnt( exception { Class::MOP::Method->wrap( sub {'FAIL'} ); }, undef, '... bad args for &wrap' ); isnt( exception { Class::MOP::Method->wrap( sub {'FAIL'}, package_name => 'main' ); }, undef, '... bad args for &wrap' ); isnt( exception { Class::MOP::Method->wrap( sub {'FAIL'}, name => '__ANON__' ); }, undef, '... bad args for &wrap' ); is( exception { Class::MOP::Method->wrap( bless( sub {'FAIL'}, "Foo" ), name => '__ANON__', package_name => 'Foo::Bar' ); }, undef, '... blessed coderef to &wrap' ); my $clone = $method->clone( package_name => 'NewPackage', name => 'new_name', ); isa_ok( $clone, 'Class::MOP::Method' ); is( $clone->package_name, 'NewPackage', '... cloned method has new package name' ); is( $clone->name, 'new_name', '... cloned method has new sub name' ); is( $clone->fully_qualified_name, 'NewPackage::new_name', '... cloned method has new fq name' ); is( $clone->original_method, $method, '... cloned method has correct original_method' ); is( $clone->original_package_name, 'main', '... cloned method has correct original_package_name' ); is( $clone->original_name, '__ANON__', '... cloned method has correct original_name' ); is( $clone->original_fully_qualified_name, 'main::__ANON__', '... cloned method has correct original_fully_qualified_name' ); my $clone2 = $clone->clone( package_name => 'NewerPackage', name => 'newer_name', ); is( $clone2->package_name, 'NewerPackage', '... clone of clone has new package name' ); is( $clone2->name, 'newer_name', '... clone of clone has new sub name' ); is( $clone2->fully_qualified_name, 'NewerPackage::newer_name', '... clone of clone new fq name' ); is( $clone2->original_method, $clone, '... cloned method has correct original_method' ); is( $clone2->original_package_name, 'main', '... original_package_name follows clone chain' ); is( $clone2->original_name, '__ANON__', '... original_name follows clone chain' ); is( $clone2->original_fully_qualified_name, 'main::__ANON__', '... original_fully_qualified_name follows clone chain' ); Class::MOP::Class->create( 'Method::Subclass', superclasses => ['Class::MOP::Method'], attributes => [ Class::MOP::Attribute->new( foo => ( accessor => 'foo', ) ), ], ); my $wrapped = Method::Subclass->wrap($method, foo => 'bar'); isa_ok($wrapped, 'Method::Subclass'); isa_ok($wrapped, 'Class::MOP::Method'); is($wrapped->foo, 'bar', 'attribute set properly'); is($wrapped->package_name, 'main', 'package_name copied properly'); is($wrapped->name, '__ANON__', 'method name copied properly'); my $wrapped2 = Method::Subclass->wrap($method, foo => 'baz', name => 'FOO'); is($wrapped2->name, 'FOO', 'got a new method name'); { package Foo; sub full {1} sub stub; } { my $meta = Class::MOP::Class->initialize('Foo'); ok( $meta->has_method($_), "Foo class has $_ method" ) for qw( full stub ); my $full = $meta->get_method('full'); ok( !$full->is_stub, 'full is not a stub' ); my $stub = $meta->get_method('stub'); ok( $stub->is_stub, 'stub is a stub' ); } done_testing; build.t100644000767000024 310412200352344 15205 0ustar00etherstaff000000000000Moose-2.1005/t/roles#!/usr/bin/env perl use strict; use warnings; use Test::More; use Test::Requires { 'Test::Output' => '0.01', # skip all if not installed }; # this test script ensures that my idiom of: # role: sub BUILD, after BUILD # continues to work to run code after object initialization, whether the class # has a BUILD method or not my @CALLS; do { package TestRole; use Moose::Role; sub BUILD { push @CALLS, 'TestRole::BUILD' } before BUILD => sub { push @CALLS, 'TestRole::BUILD:before' }; after BUILD => sub { push @CALLS, 'TestRole::BUILD:after' }; }; do { package ClassWithBUILD; use Moose; ::stderr_is { with 'TestRole'; } ''; sub BUILD { push @CALLS, 'ClassWithBUILD::BUILD' } }; do { package ExplicitClassWithBUILD; use Moose; ::stderr_is { with 'TestRole' => { -excludes => 'BUILD' }; } ''; sub BUILD { push @CALLS, 'ExplicitClassWithBUILD::BUILD' } }; do { package ClassWithoutBUILD; use Moose; with 'TestRole'; }; { is_deeply([splice @CALLS], [], "no calls to BUILD yet"); ClassWithBUILD->new; is_deeply([splice @CALLS], [ 'TestRole::BUILD:before', 'ClassWithBUILD::BUILD', 'TestRole::BUILD:after', ]); ClassWithoutBUILD->new; is_deeply([splice @CALLS], [ 'TestRole::BUILD:before', 'TestRole::BUILD', 'TestRole::BUILD:after', ]); if (ClassWithBUILD->meta->is_mutable) { ClassWithBUILD->meta->make_immutable; ClassWithoutBUILD->meta->make_immutable; redo; } } done_testing; Attribute.xs100644000767000024 34112200352344 15263 0ustar00etherstaff000000000000Moose-2.1005/xs#include "mop.h" MODULE = Class::MOP::Attribute PACKAGE = Class::MOP::Attribute PROTOTYPES: DISABLE BOOT: INSTALL_SIMPLE_READER(Attribute, associated_class); INSTALL_SIMPLE_READER(Attribute, associated_methods); Generated.xs100644000767000024 37212200352344 15222 0ustar00etherstaff000000000000Moose-2.1005/xs#include "mop.h" MODULE = Class::MOP::Method::Generated PACKAGE = Class::MOP::Method::Generated PROTOTYPES: DISABLE BOOT: INSTALL_SIMPLE_READER(Method::Generated, is_inline); INSTALL_SIMPLE_READER(Method::Generated, definition_context); MakeMaker.pm100644000767000024 133212200352344 15277 0ustar00etherstaff000000000000Moose-2.1005/incpackage inc::MakeMaker; use Moose; use lib 'inc'; use MMHelper; extends 'Dist::Zilla::Plugin::MakeMaker::Awesome'; override _build_MakeFile_PL_template => sub { my $self = shift; my $tmpl = super(); my $ccflags = MMHelper::ccflags_dyn(); $tmpl =~ s/^(WriteMakefile\()/\$WriteMakefileArgs{CCFLAGS} = $ccflags;\n\n$1/m; return $tmpl . "\n\n" . MMHelper::my_package_subs(); }; override _build_WriteMakefile_args => sub { my $self = shift; my $args = super(); return { %{$args}, MMHelper::mm_args(), }; }; override test => sub { my $self = shift; local $ENV{PERL5LIB} = join ':', grep {defined} @ENV{ 'PERL5LIB', 'DZIL_TEST_INC' }; super(); }; 1; metaclass.pm100644000767000024 566412200352344 15427 0ustar00etherstaff000000000000Moose-2.1005/lib package metaclass; BEGIN { $metaclass::AUTHORITY = 'cpan:STEVAN'; } { $metaclass::VERSION = '2.1005'; } use strict; use warnings; use Carp 'confess'; use Class::Load 'load_class'; use Scalar::Util 'blessed'; use Try::Tiny; use Class::MOP; sub import { my ( $class, @args ) = @_; unshift @args, "metaclass" if @args % 2 == 1; my %options = @args; my $meta_name = exists $options{meta_name} ? $options{meta_name} : 'meta'; my $metaclass = delete $options{metaclass}; unless ( defined $metaclass ) { $metaclass = "Class::MOP::Class"; } else { load_class($metaclass); } ($metaclass->isa('Class::MOP::Class')) || confess "The metaclass ($metaclass) must be derived from Class::MOP::Class"; # make sure the custom metaclasses get loaded foreach my $key (grep { /_(?:meta)?class$/ } keys %options) { unless ( ref( my $class = $options{$key} ) ) { load_class($class) } } my $package = caller(); # create a meta object so we can install &meta my $meta = $metaclass->initialize($package => %options); $meta->_add_meta_method($meta_name) if defined $meta_name; } 1; # ABSTRACT: a pragma for installing and using Class::MOP metaclasses __END__ =pod =head1 NAME metaclass - a pragma for installing and using Class::MOP metaclasses =head1 VERSION version 2.1005 =head1 SYNOPSIS package MyClass; # use Class::MOP::Class use metaclass; # ... or use a custom metaclass use metaclass 'MyMetaClass'; # ... or use a custom metaclass # and custom attribute and method # metaclasses use metaclass 'MyMetaClass' => ( 'attribute_metaclass' => 'MyAttributeMetaClass', 'method_metaclass' => 'MyMethodMetaClass', ); # ... or just specify custom attribute # and method classes, and Class::MOP::Class # is the assumed metaclass use metaclass ( 'attribute_metaclass' => 'MyAttributeMetaClass', 'method_metaclass' => 'MyMethodMetaClass', ); # if we'd rather not install a 'meta' method, we can do this use metaclass meta_name => undef; # or if we'd like it to have a different name, use metaclass meta_name => 'my_meta'; =head1 DESCRIPTION This is a pragma to make it easier to use a specific metaclass and a set of custom attribute and method metaclasses. It also installs a C method to your class as well, unless C is passed to the C option. Note that if you are using Moose, you most likely do B want to be using this - look into L instead. =head1 AUTHOR Moose is maintained by the Moose Cabal, along with the help of many contributors. See L and L for details. =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2013 by Infinity Interactive, Inc.. This is free software; you can redistribute it and/or modify it under the same terms as the Perl 5 programming language system itself. =cut Class000755000767000024 012200352344 14007 5ustar00etherstaff000000000000Moose-2.1005/libMOP.pm100644000767000024 10772312200352344 15212 0ustar00etherstaff000000000000Moose-2.1005/lib/Class package Class::MOP; BEGIN { $Class::MOP::AUTHORITY = 'cpan:STEVAN'; } { $Class::MOP::VERSION = '2.1005'; } use strict; use warnings; use 5.008; use MRO::Compat; use Carp 'confess'; use Class::Load 0.07 (); use Scalar::Util 'weaken', 'isweak', 'reftype', 'blessed'; use Data::OptList; use Try::Tiny; use Class::MOP::Mixin::AttributeCore; use Class::MOP::Mixin::HasAttributes; use Class::MOP::Mixin::HasMethods; use Class::MOP::Class; use Class::MOP::Attribute; use Class::MOP::Method; BEGIN { *IS_RUNNING_ON_5_10 = ($] < 5.009_005) ? sub () { 0 } : sub () { 1 }; # this is either part of core or set up appropriately by MRO::Compat *check_package_cache_flag = \&mro::get_pkg_gen; } XSLoader::load( 'Moose', $Class::MOP::{VERSION} ? ${ $Class::MOP::{VERSION} } : () ); { # Metaclasses are singletons, so we cache them here. # there is no need to worry about destruction though # because they should die only when the program dies. # After all, do package definitions even get reaped? # Anonymous classes manage their own destruction. my %METAS; sub get_all_metaclasses { %METAS } sub get_all_metaclass_instances { values %METAS } sub get_all_metaclass_names { keys %METAS } sub get_metaclass_by_name { $METAS{$_[0]} } sub store_metaclass_by_name { $METAS{$_[0]} = $_[1] } sub weaken_metaclass { weaken($METAS{$_[0]}) } sub metaclass_is_weak { isweak($METAS{$_[0]}) } sub does_metaclass_exist { exists $METAS{$_[0]} && defined $METAS{$_[0]} } sub remove_metaclass_by_name { delete $METAS{$_[0]}; return } # This handles instances as well as class names sub class_of { return unless defined $_[0]; my $class = blessed($_[0]) || $_[0]; return $METAS{$class}; } # NOTE: # We only cache metaclasses, meaning instances of # Class::MOP::Class. We do not cache instance of # Class::MOP::Package or Class::MOP::Module. Mostly # because I don't yet see a good reason to do so. } sub load_class { goto &Class::Load::load_class; } sub load_first_existing_class { goto &Class::Load::load_first_existing_class; } sub is_class_loaded { goto &Class::Load::is_class_loaded; } sub _definition_context { my %context; @context{qw(package file line)} = caller(1); return ( definition_context => \%context, ); } ## ---------------------------------------------------------------------------- ## Setting up our environment ... ## ---------------------------------------------------------------------------- ## Class::MOP needs to have a few things in the global perl environment so ## that it can operate effectively. Those things are done here. ## ---------------------------------------------------------------------------- # ... nothing yet actually ;) ## ---------------------------------------------------------------------------- ## Bootstrapping ## ---------------------------------------------------------------------------- ## The code below here is to bootstrap our MOP with itself. This is also ## sometimes called "tying the knot". By doing this, we make it much easier ## to extend the MOP through subclassing and such since now you can use the ## MOP itself to extend itself. ## ## Yes, I know, that's weird and insane, but it's a good thing, trust me :) ## ---------------------------------------------------------------------------- # We need to add in the meta-attributes here so that # any subclass of Class::MOP::* will be able to # inherit them using _construct_instance ## -------------------------------------------------------- ## Class::MOP::Mixin::HasMethods Class::MOP::Mixin::HasMethods->meta->add_attribute( Class::MOP::Attribute->new('_methods' => ( reader => { # NOTE: # we just alias the original method # rather than re-produce it here '_method_map' => \&Class::MOP::Mixin::HasMethods::_method_map }, default => sub { {} }, _definition_context(), )) ); Class::MOP::Mixin::HasMethods->meta->add_attribute( Class::MOP::Attribute->new('method_metaclass' => ( reader => { # NOTE: # we just alias the original method # rather than re-produce it here 'method_metaclass' => \&Class::MOP::Mixin::HasMethods::method_metaclass }, default => 'Class::MOP::Method', _definition_context(), )) ); Class::MOP::Mixin::HasMethods->meta->add_attribute( Class::MOP::Attribute->new('wrapped_method_metaclass' => ( reader => { # NOTE: # we just alias the original method # rather than re-produce it here 'wrapped_method_metaclass' => \&Class::MOP::Mixin::HasMethods::wrapped_method_metaclass }, default => 'Class::MOP::Method::Wrapped', _definition_context(), )) ); ## -------------------------------------------------------- ## Class::MOP::Mixin::HasMethods Class::MOP::Mixin::HasAttributes->meta->add_attribute( Class::MOP::Attribute->new('attributes' => ( reader => { # NOTE: we need to do this in order # for the instance meta-object to # not fall into meta-circular death # # we just alias the original method # rather than re-produce it here '_attribute_map' => \&Class::MOP::Mixin::HasAttributes::_attribute_map }, default => sub { {} }, _definition_context(), )) ); Class::MOP::Mixin::HasAttributes->meta->add_attribute( Class::MOP::Attribute->new('attribute_metaclass' => ( reader => { # NOTE: # we just alias the original method # rather than re-produce it here 'attribute_metaclass' => \&Class::MOP::Mixin::HasAttributes::attribute_metaclass }, default => 'Class::MOP::Attribute', _definition_context(), )) ); ## -------------------------------------------------------- ## Class::MOP::Package Class::MOP::Package->meta->add_attribute( Class::MOP::Attribute->new('package' => ( reader => { # NOTE: we need to do this in order # for the instance meta-object to # not fall into meta-circular death # # we just alias the original method # rather than re-produce it here 'name' => \&Class::MOP::Package::name }, _definition_context(), )) ); Class::MOP::Package->meta->add_attribute( Class::MOP::Attribute->new('namespace' => ( reader => { # NOTE: # we just alias the original method # rather than re-produce it here 'namespace' => \&Class::MOP::Package::namespace }, init_arg => undef, default => sub { \undef }, _definition_context(), )) ); ## -------------------------------------------------------- ## Class::MOP::Module # NOTE: # yeah this is kind of stretching things a bit, # but truthfully the version should be an attribute # of the Module, the weirdness comes from having to # stick to Perl 5 convention and store it in the # $VERSION package variable. Basically if you just # squint at it, it will look how you want it to look. # Either as a package variable, or as a attribute of # the metaclass, isn't abstraction great :) Class::MOP::Module->meta->add_attribute( Class::MOP::Attribute->new('version' => ( reader => { # NOTE: # we just alias the original method # rather than re-produce it here 'version' => \&Class::MOP::Module::version }, init_arg => undef, default => sub { \undef }, _definition_context(), )) ); # NOTE: # By following the same conventions as version here, # we are opening up the possibility that people can # use the $AUTHORITY in non-Class::MOP modules as # well. Class::MOP::Module->meta->add_attribute( Class::MOP::Attribute->new('authority' => ( reader => { # NOTE: # we just alias the original method # rather than re-produce it here 'authority' => \&Class::MOP::Module::authority }, init_arg => undef, default => sub { \undef }, _definition_context(), )) ); ## -------------------------------------------------------- ## Class::MOP::Class Class::MOP::Class->meta->add_attribute( Class::MOP::Attribute->new('superclasses' => ( accessor => { # NOTE: # we just alias the original method # rather than re-produce it here 'superclasses' => \&Class::MOP::Class::superclasses }, init_arg => undef, default => sub { \undef }, _definition_context(), )) ); Class::MOP::Class->meta->add_attribute( Class::MOP::Attribute->new('instance_metaclass' => ( reader => { # NOTE: we need to do this in order # for the instance meta-object to # not fall into meta-circular death # # we just alias the original method # rather than re-produce it here 'instance_metaclass' => \&Class::MOP::Class::instance_metaclass }, default => 'Class::MOP::Instance', _definition_context(), )) ); Class::MOP::Class->meta->add_attribute( Class::MOP::Attribute->new('immutable_trait' => ( reader => { 'immutable_trait' => \&Class::MOP::Class::immutable_trait }, default => "Class::MOP::Class::Immutable::Trait", _definition_context(), )) ); Class::MOP::Class->meta->add_attribute( Class::MOP::Attribute->new('constructor_name' => ( reader => { 'constructor_name' => \&Class::MOP::Class::constructor_name, }, default => "new", _definition_context(), )) ); Class::MOP::Class->meta->add_attribute( Class::MOP::Attribute->new('constructor_class' => ( reader => { 'constructor_class' => \&Class::MOP::Class::constructor_class, }, default => "Class::MOP::Method::Constructor", _definition_context(), )) ); Class::MOP::Class->meta->add_attribute( Class::MOP::Attribute->new('destructor_class' => ( reader => { 'destructor_class' => \&Class::MOP::Class::destructor_class, }, _definition_context(), )) ); # NOTE: # we don't actually need to tie the knot with # Class::MOP::Class here, it is actually handled # within Class::MOP::Class itself in the # _construct_class_instance method. ## -------------------------------------------------------- ## Class::MOP::Mixin::AttributeCore Class::MOP::Mixin::AttributeCore->meta->add_attribute( Class::MOP::Attribute->new('name' => ( reader => { # NOTE: we need to do this in order # for the instance meta-object to # not fall into meta-circular death # # we just alias the original method # rather than re-produce it here 'name' => \&Class::MOP::Mixin::AttributeCore::name }, _definition_context(), )) ); Class::MOP::Mixin::AttributeCore->meta->add_attribute( Class::MOP::Attribute->new('accessor' => ( reader => { 'accessor' => \&Class::MOP::Mixin::AttributeCore::accessor }, predicate => { 'has_accessor' => \&Class::MOP::Mixin::AttributeCore::has_accessor }, _definition_context(), )) ); Class::MOP::Mixin::AttributeCore->meta->add_attribute( Class::MOP::Attribute->new('reader' => ( reader => { 'reader' => \&Class::MOP::Mixin::AttributeCore::reader }, predicate => { 'has_reader' => \&Class::MOP::Mixin::AttributeCore::has_reader }, _definition_context(), )) ); Class::MOP::Mixin::AttributeCore->meta->add_attribute( Class::MOP::Attribute->new('initializer' => ( reader => { 'initializer' => \&Class::MOP::Mixin::AttributeCore::initializer }, predicate => { 'has_initializer' => \&Class::MOP::Mixin::AttributeCore::has_initializer }, _definition_context(), )) ); Class::MOP::Mixin::AttributeCore->meta->add_attribute( Class::MOP::Attribute->new('definition_context' => ( reader => { 'definition_context' => \&Class::MOP::Mixin::AttributeCore::definition_context }, _definition_context(), )) ); Class::MOP::Mixin::AttributeCore->meta->add_attribute( Class::MOP::Attribute->new('writer' => ( reader => { 'writer' => \&Class::MOP::Mixin::AttributeCore::writer }, predicate => { 'has_writer' => \&Class::MOP::Mixin::AttributeCore::has_writer }, _definition_context(), )) ); Class::MOP::Mixin::AttributeCore->meta->add_attribute( Class::MOP::Attribute->new('predicate' => ( reader => { 'predicate' => \&Class::MOP::Mixin::AttributeCore::predicate }, predicate => { 'has_predicate' => \&Class::MOP::Mixin::AttributeCore::has_predicate }, _definition_context(), )) ); Class::MOP::Mixin::AttributeCore->meta->add_attribute( Class::MOP::Attribute->new('clearer' => ( reader => { 'clearer' => \&Class::MOP::Mixin::AttributeCore::clearer }, predicate => { 'has_clearer' => \&Class::MOP::Mixin::AttributeCore::has_clearer }, _definition_context(), )) ); Class::MOP::Mixin::AttributeCore->meta->add_attribute( Class::MOP::Attribute->new('builder' => ( reader => { 'builder' => \&Class::MOP::Mixin::AttributeCore::builder }, predicate => { 'has_builder' => \&Class::MOP::Mixin::AttributeCore::has_builder }, _definition_context(), )) ); Class::MOP::Mixin::AttributeCore->meta->add_attribute( Class::MOP::Attribute->new('init_arg' => ( reader => { 'init_arg' => \&Class::MOP::Mixin::AttributeCore::init_arg }, predicate => { 'has_init_arg' => \&Class::MOP::Mixin::AttributeCore::has_init_arg }, _definition_context(), )) ); Class::MOP::Mixin::AttributeCore->meta->add_attribute( Class::MOP::Attribute->new('default' => ( # default has a custom 'reader' method ... predicate => { 'has_default' => \&Class::MOP::Mixin::AttributeCore::has_default }, _definition_context(), )) ); Class::MOP::Mixin::AttributeCore->meta->add_attribute( Class::MOP::Attribute->new('insertion_order' => ( reader => { 'insertion_order' => \&Class::MOP::Mixin::AttributeCore::insertion_order }, writer => { '_set_insertion_order' => \&Class::MOP::Mixin::AttributeCore::_set_insertion_order }, predicate => { 'has_insertion_order' => \&Class::MOP::Mixin::AttributeCore::has_insertion_order }, _definition_context(), )) ); ## -------------------------------------------------------- ## Class::MOP::Attribute Class::MOP::Attribute->meta->add_attribute( Class::MOP::Attribute->new('associated_class' => ( reader => { # NOTE: we need to do this in order # for the instance meta-object to # not fall into meta-circular death # # we just alias the original method # rather than re-produce it here 'associated_class' => \&Class::MOP::Attribute::associated_class }, _definition_context(), )) ); Class::MOP::Attribute->meta->add_attribute( Class::MOP::Attribute->new('associated_methods' => ( reader => { 'associated_methods' => \&Class::MOP::Attribute::associated_methods }, default => sub { [] }, _definition_context(), )) ); Class::MOP::Attribute->meta->add_method('clone' => sub { my $self = shift; $self->meta->clone_object($self, @_); }); ## -------------------------------------------------------- ## Class::MOP::Method Class::MOP::Method->meta->add_attribute( Class::MOP::Attribute->new('body' => ( reader => { 'body' => \&Class::MOP::Method::body }, _definition_context(), )) ); Class::MOP::Method->meta->add_attribute( Class::MOP::Attribute->new('associated_metaclass' => ( reader => { 'associated_metaclass' => \&Class::MOP::Method::associated_metaclass }, _definition_context(), )) ); Class::MOP::Method->meta->add_attribute( Class::MOP::Attribute->new('package_name' => ( reader => { 'package_name' => \&Class::MOP::Method::package_name }, _definition_context(), )) ); Class::MOP::Method->meta->add_attribute( Class::MOP::Attribute->new('name' => ( reader => { 'name' => \&Class::MOP::Method::name }, _definition_context(), )) ); Class::MOP::Method->meta->add_attribute( Class::MOP::Attribute->new('original_method' => ( reader => { 'original_method' => \&Class::MOP::Method::original_method }, writer => { '_set_original_method' => \&Class::MOP::Method::_set_original_method }, _definition_context(), )) ); ## -------------------------------------------------------- ## Class::MOP::Method::Wrapped # NOTE: # the way this item is initialized, this # really does not follow the standard # practices of attributes, but we put # it here for completeness Class::MOP::Method::Wrapped->meta->add_attribute( Class::MOP::Attribute->new('modifier_table' => ( _definition_context(), )) ); ## -------------------------------------------------------- ## Class::MOP::Method::Generated Class::MOP::Method::Generated->meta->add_attribute( Class::MOP::Attribute->new('is_inline' => ( reader => { 'is_inline' => \&Class::MOP::Method::Generated::is_inline }, default => 0, _definition_context(), )) ); Class::MOP::Method::Generated->meta->add_attribute( Class::MOP::Attribute->new('definition_context' => ( reader => { 'definition_context' => \&Class::MOP::Method::Generated::definition_context }, _definition_context(), )) ); ## -------------------------------------------------------- ## Class::MOP::Method::Inlined Class::MOP::Method::Inlined->meta->add_attribute( Class::MOP::Attribute->new('_expected_method_class' => ( reader => { '_expected_method_class' => \&Class::MOP::Method::Inlined::_expected_method_class }, _definition_context(), )) ); ## -------------------------------------------------------- ## Class::MOP::Method::Accessor Class::MOP::Method::Accessor->meta->add_attribute( Class::MOP::Attribute->new('attribute' => ( reader => { 'associated_attribute' => \&Class::MOP::Method::Accessor::associated_attribute }, _definition_context(), )) ); Class::MOP::Method::Accessor->meta->add_attribute( Class::MOP::Attribute->new('accessor_type' => ( reader => { 'accessor_type' => \&Class::MOP::Method::Accessor::accessor_type }, _definition_context(), )) ); ## -------------------------------------------------------- ## Class::MOP::Method::Constructor Class::MOP::Method::Constructor->meta->add_attribute( Class::MOP::Attribute->new('options' => ( reader => { 'options' => \&Class::MOP::Method::Constructor::options }, default => sub { +{} }, _definition_context(), )) ); Class::MOP::Method::Constructor->meta->add_attribute( Class::MOP::Attribute->new('associated_metaclass' => ( init_arg => "metaclass", # FIXME alias and rename reader => { 'associated_metaclass' => \&Class::MOP::Method::Constructor::associated_metaclass }, _definition_context(), )) ); ## -------------------------------------------------------- ## Class::MOP::Instance # NOTE: # these don't yet do much of anything, but are just # included for completeness Class::MOP::Instance->meta->add_attribute( Class::MOP::Attribute->new('associated_metaclass', reader => { associated_metaclass => \&Class::MOP::Instance::associated_metaclass }, _definition_context(), ), ); Class::MOP::Instance->meta->add_attribute( Class::MOP::Attribute->new('_class_name', init_arg => undef, reader => { _class_name => \&Class::MOP::Instance::_class_name }, #lazy => 1, # not yet supported by Class::MOP but out our version does it anyway #default => sub { $_[0]->associated_metaclass->name }, _definition_context(), ), ); Class::MOP::Instance->meta->add_attribute( Class::MOP::Attribute->new('attributes', reader => { attributes => \&Class::MOP::Instance::get_all_attributes }, _definition_context(), ), ); Class::MOP::Instance->meta->add_attribute( Class::MOP::Attribute->new('slots', reader => { slots => \&Class::MOP::Instance::slots }, _definition_context(), ), ); Class::MOP::Instance->meta->add_attribute( Class::MOP::Attribute->new('slot_hash', reader => { slot_hash => \&Class::MOP::Instance::slot_hash }, _definition_context(), ), ); ## -------------------------------------------------------- ## Class::MOP::Object # need to replace the meta method there with a real meta method object Class::MOP::Object->meta->_add_meta_method('meta'); ## -------------------------------------------------------- ## Class::MOP::Mixin # need to replace the meta method there with a real meta method object Class::MOP::Mixin->meta->_add_meta_method('meta'); require Class::MOP::Deprecated unless our $no_deprecated; # we need the meta instance of the meta instance to be created now, in order # for the constructor to be able to use it Class::MOP::Instance->meta->get_meta_instance; # pretend the add_method never happened. it hasn't yet affected anything undef Class::MOP::Instance->meta->{_package_cache_flag}; ## -------------------------------------------------------- ## Now close all the Class::MOP::* classes # NOTE: we don't need to inline the accessors this only lengthens the compile # time of the MOP, and gives us no actual benefits. $_->meta->make_immutable( inline_constructor => 0, constructor_name => "_new", inline_accessors => 0, ) for qw/ Class::MOP::Package Class::MOP::Module Class::MOP::Class Class::MOP::Attribute Class::MOP::Method Class::MOP::Instance Class::MOP::Object Class::MOP::Method::Generated Class::MOP::Method::Inlined Class::MOP::Method::Accessor Class::MOP::Method::Constructor Class::MOP::Method::Wrapped Class::MOP::Method::Meta Class::MOP::Method::Overload /; $_->meta->make_immutable( inline_constructor => 0, constructor_name => undef, inline_accessors => 0, ) for qw/ Class::MOP::Mixin Class::MOP::Mixin::AttributeCore Class::MOP::Mixin::HasAttributes Class::MOP::Mixin::HasMethods /; 1; # ABSTRACT: A Meta Object Protocol for Perl 5 __END__ =pod =head1 NAME Class::MOP - A Meta Object Protocol for Perl 5 =head1 VERSION version 2.1005 =head1 DESCRIPTION This module is a fully functioning meta object protocol for the Perl 5 object system. It makes no attempt to change the behavior or characteristics of the Perl 5 object system, only to create a protocol for its manipulation and introspection. That said, it does attempt to create the tools for building a rich set of extensions to the Perl 5 object system. Every attempt has been made to abide by the spirit of the Perl 5 object system that we all know and love. This documentation is sparse on conceptual details. We suggest looking at the items listed in the L section for more information. In particular the book "The Art of the Meta Object Protocol" was very influential in the development of this system. =head2 What is a Meta Object Protocol? A meta object protocol is an API to an object system. To be more specific, it abstracts the components of an object system (classes, object, methods, object attributes, etc.). These abstractions can then be used to inspect and manipulate the object system which they describe. It can be said that there are two MOPs for any object system; the implicit MOP and the explicit MOP. The implicit MOP handles things like method dispatch or inheritance, which happen automatically as part of how the object system works. The explicit MOP typically handles the introspection/reflection features of the object system. All object systems have implicit MOPs. Without one, they would not work. Explicit MOPs are much less common, and depending on the language can vary from restrictive (Reflection in Java or C#) to wide open (CLOS is a perfect example). =head2 Yet Another Class Builder! Why? This is B a class builder so much as a I>. The intent is that an end user will not use this module directly, but instead this module is used by module authors to build extensions and features onto the Perl 5 object system. This system is used by L, which supplies a powerful class builder system built entirely on top of C. =head2 Who is this module for? This module is for anyone who has ever created or wanted to create a module for the Class:: namespace. The tools which this module provides make doing complex Perl 5 wizardry simpler, by removing such barriers as the need to hack symbol tables, or understand the fine details of method dispatch. =head2 What changes do I have to make to use this module? This module was designed to be as unobtrusive as possible. Many of its features are accessible without B change to your existing code. It is meant to be a complement to your existing code and not an intrusion on your code base. Unlike many other B modules, this module B require you subclass it, or even that you C it in within your module's package. The only features which require additions to your code are the attribute handling and instance construction features, and these are both completely optional features. The only reason for this is because Perl 5's object system does not actually have these features built in. More information about this feature can be found below. =head2 About Performance It is a common misconception that explicit MOPs are a performance hit. This is not a universal truth, it is a side-effect of some specific implementations. For instance, using Java reflection is slow because the JVM cannot take advantage of any compiler optimizations, and the JVM has to deal with much more runtime type information as well. Reflection in C# is marginally better as it was designed into the language and runtime (the CLR). In contrast, CLOS (the Common Lisp Object System) was built to support an explicit MOP, and so performance is tuned for it. This library in particular does its absolute best to avoid putting B drain at all upon your code's performance. In fact, by itself it does nothing to affect your existing code. So you only pay for what you actually use. =head2 About Metaclass compatibility This module makes sure that all metaclasses created are both upwards and downwards compatible. The topic of metaclass compatibility is highly esoteric and is something only encountered when doing deep and involved metaclass hacking. There are two basic kinds of metaclass incompatibility; upwards and downwards. Upwards metaclass compatibility means that the metaclass of a given class is either the same as (or a subclass of) all of the class's ancestors. Downward metaclass compatibility means that the metaclasses of a given class's ancestors are all the same as (or a subclass of) that metaclass. Here is a diagram showing a set of two classes (C and C) and two metaclasses (C and C) which have correct metaclass compatibility both upwards and downwards. +---------+ +---------+ | Meta::A |<----| Meta::B | <....... (instance of ) +---------+ +---------+ <------- (inherits from) ^ ^ : : +---------+ +---------+ | A |<----| B | +---------+ +---------+ In actuality, I of a class's metaclasses must be compatible, not just the class metaclass. That includes the instance, attribute, and method metaclasses, as well as the constructor and destructor classes. C will attempt to fix some simple types of incompatibilities. If all the metaclasses for the parent class are I of the child's metaclasses then we can simply replace the child's metaclasses with the parent's. In addition, if the child is missing a metaclass that the parent has, we can also just make the child use the parent's metaclass. As I said this is a highly esoteric topic and one you will only run into if you do a lot of subclassing of L. If you are interested in why this is an issue see the paper I linked to in the L section of this document. =head2 Using custom metaclasses Always use the L pragma when using a custom metaclass, this will ensure the proper initialization order and not accidentally create an incorrect type of metaclass for you. This is a very rare problem, and one which can only occur if you are doing deep metaclass programming. So in other words, don't worry about it. Note that if you're using L we encourage you to I use the L pragma, and instead use L to apply roles to a class's metaclasses. This topic is covered at length in various L recipes. =head1 PROTOCOLS The meta-object protocol is divided into 4 main sub-protocols: =head2 The Class protocol This provides a means of manipulating and introspecting a Perl 5 class. It handles symbol table hacking for you, and provides a rich set of methods that go beyond simple package introspection. See L for more details. =head2 The Attribute protocol This provides a consistent representation for an attribute of a Perl 5 class. Since there are so many ways to create and handle attributes in Perl 5 OO, the Attribute protocol provide as much of a unified approach as possible. Of course, you are always free to extend this protocol by subclassing the appropriate classes. See L for more details. =head2 The Method protocol This provides a means of manipulating and introspecting methods in the Perl 5 object system. As with attributes, there are many ways to approach this topic, so we try to keep it pretty basic, while still making it possible to extend the system in many ways. See L for more details. =head2 The Instance protocol This provides a layer of abstraction for creating object instances. Since the other layers use this protocol, it is relatively easy to change the type of your instances from the default hash reference to some other type of reference. Several examples are provided in the F directory included in this distribution. See L for more details. =head1 FUNCTIONS Note that this module does not export any constants or functions. =head2 Utility functions Note that these are all called as B. =over 4 =item B This function returns two values, the name of the package the C<$code> is from and the name of the C<$code> itself. This is used by several elements of the MOP to determine where a given C<$code> reference is from. =item B This will return the metaclass of the given instance or class name. If the class lacks a metaclass, no metaclass will be initialized, and C will be returned. =back =head2 Metaclass cache functions C holds a cache of metaclasses. The following are functions (B) which can be used to access that cache. It is not recommended that you mess with these. Bad things could happen, but if you are brave and willing to risk it: go for it! =over 4 =item B This will return a hash of all the metaclass instances that have been cached by L, keyed by the package name. =item B This will return a list of all the metaclass instances that have been cached by L. =item B This will return a list of all the metaclass names that have been cached by L. =item B This will return a cached L instance, or nothing if no metaclass exists with that C<$name>. =item B This will store a metaclass in the cache at the supplied C<$key>. =item B In rare cases (e.g. anonymous metaclasses) it is desirable to store a weakened reference in the metaclass cache. This function will weaken the reference to the metaclass stored in C<$name>. =item B Returns true if the metaclass for C<$name> has been weakened (via C). =item B This will return true of there exists a metaclass stored in the C<$name> key, and return false otherwise. =item B This will remove the metaclass stored in the C<$name> key. =back Some utility functions (such as C) that were previously defined in C regarding loading of classes have been extracted to L. Please see L for documentation. =head1 SEE ALSO =head2 Books There are very few books out on Meta Object Protocols and Metaclasses because it is such an esoteric topic. The following books are really the only ones I have found. If you know of any more, B> email me and let me know, I would love to hear about them. =over 4 =item I =item I =item I =item I =back =head2 Papers =over 4 =item "Uniform and safe metaclass composition" An excellent paper by the people who brought us the original Traits paper. This paper is on how Traits can be used to do safe metaclass composition, and offers an excellent introduction section which delves into the topic of metaclass compatibility. L =item "Safe Metaclass Programming" This paper seems to precede the above paper, and propose a mix-in based approach as opposed to the Traits based approach. Both papers have similar information on the metaclass compatibility problem space. L =back =head2 Prior Art =over 4 =item The Perl 6 MetaModel work in the Pugs project =over 4 =item L =item L =back =back =head2 Articles =over 4 =item CPAN Module Review of Class::MOP L =back =head1 SIMILAR MODULES As I have said above, this module is a class-builder-builder, so it is not the same thing as modules like L and L. That being said there are very few modules on CPAN with similar goals to this module. The one I have found which is most like this module is L, although its philosophy and the MOP it creates are very different from this modules. =head1 BUGS All complex software has bugs lurking in it, and this module is no exception. Please report any bugs to C, or through the web interface at L. You can also discuss feature requests or possible bugs on the Moose mailing list (moose@perl.org) or on IRC at L. =head1 ACKNOWLEDGEMENTS =over 4 =item Rob Kinyon Thanks to Rob for actually getting the development of this module kick-started. =back =head1 AUTHOR Moose is maintained by the Moose Cabal, along with the help of many contributors. See L and L for details. =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2013 by Infinity Interactive, Inc.. This is free software; you can redistribute it and/or modify it under the same terms as the Perl 5 programming language system itself. =cut methods.t100644000767000024 2617312200352344 15416 0ustar00etherstaff000000000000Moose-2.1005/t/cmopuse strict; use warnings; use Test::More; use Test::Fatal; use Scalar::Util qw/reftype/; use Sub::Name; use Class::MOP; use Class::MOP::Class; use Class::MOP::Method; { # This package tries to test &has_method as exhaustively as # possible. More corner cases are welcome :) package Foo; # import a sub use Scalar::Util 'blessed'; sub pie; sub cake (); use constant FOO_CONSTANT => 'Foo-CONSTANT'; # define a sub in package sub bar {'Foo::bar'} *baz = \&bar; # create something with the typeglob inside the package *baaz = sub {'Foo::baaz'}; { # method named with Sub::Name inside the package scope no strict 'refs'; *{'Foo::floob'} = Sub::Name::subname 'floob' => sub {'!floob!'}; } # We hateses the "used only once" warnings { my $temp1 = \&Foo::baz; my $temp2 = \&Foo::baaz; } package OinkyBoinky; our @ISA = "Foo"; sub elk {'OinkyBoinky::elk'} package main; sub Foo::blah { $_[0]->Foo::baz() } { no strict 'refs'; *{'Foo::bling'} = sub {'$$Bling$$'}; *{'Foo::bang'} = Sub::Name::subname 'Foo::bang' => sub {'!BANG!'}; *{'Foo::boom'} = Sub::Name::subname 'boom' => sub {'!BOOM!'}; eval "package Foo; sub evaled_foo { 'Foo::evaled_foo' }"; } } my $Foo = Class::MOP::Class->initialize('Foo'); is join(' ', sort $Foo->get_method_list), 'FOO_CONSTANT baaz bang bar baz blah cake evaled_foo floob pie'; ok( $Foo->has_method('pie'), '... got the method stub pie' ); ok( $Foo->has_method('cake'), '... got the constant method stub cake' ); my $foo = sub {'Foo::foo'}; ok( !UNIVERSAL::isa( $foo, 'Class::MOP::Method' ), '... our method is not yet blessed' ); is( exception { $Foo->add_method( 'foo' => $foo ); }, undef, '... we added the method successfully' ); my $foo_method = $Foo->get_method('foo'); isa_ok( $foo_method, 'Class::MOP::Method' ); is( $foo_method->name, 'foo', '... got the right name for the method' ); is( $foo_method->package_name, 'Foo', '... got the right package name for the method' ); ok( $Foo->has_method('foo'), '... Foo->has_method(foo) (defined with Sub::Name)' ); is( $Foo->get_method('foo')->body, $foo, '... Foo->get_method(foo) == \&foo' ); is( $Foo->get_method('foo')->execute, 'Foo::foo', '... _method_foo->execute returns "Foo::foo"' ); is( Foo->foo(), 'Foo::foo', '... Foo->foo() returns "Foo::foo"' ); my $bork_blessed = bless sub { }, 'Non::Meta::Class'; is( exception { $Foo->add_method('bork', $bork_blessed); }, undef, 'can add blessed sub as method'); # now check all our other items ... ok( $Foo->has_method('FOO_CONSTANT'), '... not Foo->has_method(FOO_CONSTANT) (defined w/ use constant)' ); ok( !$Foo->has_method('bling'), '... not Foo->has_method(bling) (defined in main:: using symbol tables (no Sub::Name))' ); ok( $Foo->has_method('bar'), '... Foo->has_method(bar) (defined in Foo)' ); ok( $Foo->has_method('baz'), '... Foo->has_method(baz) (typeglob aliased within Foo)' ); ok( $Foo->has_method('baaz'), '... Foo->has_method(baaz) (typeglob aliased within Foo)' ); ok( $Foo->has_method('floob'), '... Foo->has_method(floob) (defined in Foo:: using symbol tables and Sub::Name w/out package name)' ); ok( $Foo->has_method('blah'), '... Foo->has_method(blah) (defined in main:: using fully qualified package name)' ); ok( $Foo->has_method('bang'), '... Foo->has_method(bang) (defined in main:: using symbol tables and Sub::Name)' ); ok( $Foo->has_method('evaled_foo'), '... Foo->has_method(evaled_foo) (evaled in main::)' ); my $OinkyBoinky = Class::MOP::Class->initialize('OinkyBoinky'); ok( $OinkyBoinky->has_method('elk'), "the method 'elk' is defined in OinkyBoinky" ); ok( !$OinkyBoinky->has_method('bar'), "the method 'bar' is not defined in OinkyBoinky" ); ok( my $bar = $OinkyBoinky->find_method_by_name('bar'), "but if you look in the inheritence chain then 'bar' does exist" ); is( reftype( $bar->body ), "CODE", "the returned value is a code ref" ); # calling get_method blessed them all for my $method_name ( qw/baaz bar baz floob blah bang bork evaled_foo FOO_CONSTANT/ ) { isa_ok( $Foo->get_method($method_name), 'Class::MOP::Method' ); { no strict 'refs'; is( $Foo->get_method($method_name)->body, \&{ 'Foo::' . $method_name }, '... body matches CODE ref in package for ' . $method_name ); } } for my $method_name ( qw/ bling / ) { is( ref( $Foo->get_package_symbol( '&' . $method_name ) ), 'CODE', '... got the __ANON__ methods' ); { no strict 'refs'; is( $Foo->get_package_symbol( '&' . $method_name ), \&{ 'Foo::' . $method_name }, '... symbol matches CODE ref in package for ' . $method_name ); } } ok( !$Foo->has_method('blessed'), '... !Foo->has_method(blessed) (imported into Foo)' ); ok( !$Foo->has_method('boom'), '... !Foo->has_method(boom) (defined in main:: using symbol tables and Sub::Name w/out package name)' ); ok( !$Foo->has_method('not_a_real_method'), '... !Foo->has_method(not_a_real_method) (does not exist)' ); is( $Foo->get_method('not_a_real_method'), undef, '... Foo->get_method(not_a_real_method) == undef' ); is_deeply( [ sort $Foo->get_method_list ], [qw(FOO_CONSTANT baaz bang bar baz blah bork cake evaled_foo floob foo pie)], '... got the right method list for Foo' ); my @universal_methods = qw/isa can VERSION/; push @universal_methods, 'DOES' if $] >= 5.010; is_deeply( [ map { $_->name => $_ } sort { $a->name cmp $b->name } $Foo->get_all_methods() ], [ map { $_->name => $_ } map { $Foo->find_method_by_name($_) } sort qw( FOO_CONSTANT baaz bang bar baz blah bork cake evaled_foo floob foo pie ), @universal_methods, ], '... got the right list of applicable methods for Foo' ); is( $Foo->remove_method('foo')->body, $foo, '... removed the foo method' ); ok( !$Foo->has_method('foo'), '... !Foo->has_method(foo) we just removed it' ); isnt( exception { Foo->foo }, undef, '... cannot call Foo->foo because it is not there' ); is_deeply( [ sort $Foo->get_method_list ], [qw(FOO_CONSTANT baaz bang bar baz blah bork cake evaled_foo floob pie)], '... got the right method list for Foo' ); # ... test our class creator my $Bar = Class::MOP::Class->create( package => 'Bar', superclasses => ['Foo'], methods => { foo => sub {'Bar::foo'}, bar => sub {'Bar::bar'}, } ); isa_ok( $Bar, 'Class::MOP::Class' ); ok( $Bar->has_method('foo'), '... Bar->has_method(foo)' ); ok( $Bar->has_method('bar'), '... Bar->has_method(bar)' ); is( Bar->foo, 'Bar::foo', '... Bar->foo == Bar::foo' ); is( Bar->bar, 'Bar::bar', '... Bar->bar == Bar::bar' ); is( exception { $Bar->add_method( 'foo' => sub {'Bar::foo v2'} ); }, undef, '... overwriting a method is fine' ); is_deeply( [ Class::MOP::get_code_info( $Bar->get_method('foo')->body ) ], [ "Bar", "foo" ], "subname applied to anonymous method" ); ok( $Bar->has_method('foo'), '... Bar-> (still) has_method(foo)' ); is( Bar->foo, 'Bar::foo v2', '... Bar->foo == "Bar::foo v2"' ); is_deeply( [ sort $Bar->get_method_list ], [qw(bar foo meta)], '... got the right method list for Bar' ); is_deeply( [ map { $_->name => $_ } sort { $a->name cmp $b->name } $Bar->get_all_methods() ], [ map { $_->name => $_ } sort { $a->name cmp $b->name } ( $Foo->get_method('FOO_CONSTANT'), $Foo->get_method('baaz'), $Foo->get_method('bang'), $Bar->get_method('bar'), ( map { $Foo->get_method($_) } qw( baz blah bork cake evaled_foo floob ) ), $Bar->get_method('foo'), $Bar->get_method('meta'), $Foo->get_method('pie'), ( map { $Bar->find_next_method_by_name($_) } @universal_methods ) ) ], '... got the right list of applicable methods for Bar' ); my $method = Class::MOP::Method->wrap( name => 'objecty', package_name => 'Whatever', body => sub {q{I am an object, and I feel an object's pain}}, ); Bar->meta->add_method( $method->name, $method ); my $new_method = Bar->meta->get_method('objecty'); isnt( $method, $new_method, 'add_method clones method objects as they are added' ); is( $new_method->original_method, $method, '... the cloned method has the correct original method' ) or diag $new_method->dump; { package CustomAccessor; use Class::MOP; my $meta = Class::MOP::Class->initialize(__PACKAGE__); $meta->add_attribute( foo => ( accessor => 'foo', ) ); { no warnings 'redefine', 'once'; *foo = sub { my $self = shift; $self->{custom_store} = $_[0]; }; } $meta->add_around_method_modifier( 'foo', sub { my $orig = shift; $orig->(@_); } ); sub new { return bless {}, shift; } } { my $o = CustomAccessor->new; my $str = 'string'; $o->foo($str); is( $o->{custom_store}, $str, 'Custom glob-assignment-created accessor still has method modifier' ); } { # Since the sub reference below is not a closure, Perl caches it and uses # the same reference each time through the loop. See RT #48985 for the # bug. foreach my $ns ( qw( Foo2 Bar2 Baz2 ) ) { my $meta = Class::MOP::Class->create($ns); my $sub = sub { }; $meta->add_method( 'foo', $sub ); my $method = $meta->get_method('foo'); ok( $method, 'Got the foo method back' ); } } { package HasConstants; use constant FOO => 1; use constant BAR => []; use constant BAZ => {}; use constant UNDEF => undef; sub quux {1} sub thing {1} } my $HC = Class::MOP::Class->initialize('HasConstants'); is_deeply( [ sort $HC->get_method_list ], [qw( BAR BAZ FOO UNDEF quux thing )], 'get_method_list handles constants properly' ); is_deeply( [ sort map { $_->name } $HC->_get_local_methods ], [qw( BAR BAZ FOO UNDEF quux thing )], '_get_local_methods handles constants properly' ); { package DeleteFromMe; sub foo { 1 } } { my $DFMmeta = Class::MOP::Class->initialize('DeleteFromMe'); ok($DFMmeta->get_method('foo')); delete $DeleteFromMe::{foo}; ok(!$DFMmeta->get_method('foo')); ok(!DeleteFromMe->can('foo')); } { my $baz_meta = Class::MOP::Class->initialize('Baz'); $baz_meta->add_method(foo => sub { }); my $stash = Package::Stash->new('Baz'); $stash->remove_symbol('&foo'); is_deeply([$baz_meta->get_method_list], [], "method is deleted"); ok(!Baz->can('foo'), "Baz can't foo"); } done_testing; subname.t100644000767000024 152112200352344 15353 0ustar00etherstaff000000000000Moose-2.1005/t/cmopuse strict; use warnings; use Test::More; use Class::MOP; { package Origin; sub bar { ( caller(0) )[3] } package Foo; } my $Foo = Class::MOP::Class->initialize('Foo'); $Foo->add_method( foo => sub { ( caller(0) )[3] } ); is_deeply( [ Class::MOP::get_code_info( $Foo->get_method('foo')->body ) ], [ "Foo", "foo" ], "subname applied to anonymous method", ); is( Foo->foo, "Foo::foo", "caller() aggrees" ); $Foo->add_method( bar => \&Origin::bar ); is( Origin->bar, "Origin::bar", "normal caller() operation in unrelated class" ); is_deeply( [ Class::MOP::get_code_info( $Foo->get_method('foo')->body ) ], [ "Foo", "foo" ], "subname not applied if a name already exists", ); is( Foo->bar, "Origin::bar", "caller aggrees" ); is( Origin->bar, "Origin::bar", "unrelated class untouched" ); done_testing; HasMethods.xs100644000767000024 530612200352344 15405 0ustar00etherstaff000000000000Moose-2.1005/xs#include "mop.h" SV *mop_method_metaclass; SV *mop_associated_metaclass; SV *mop_wrap; static void mop_update_method_map(pTHX_ HV *const stash, HV *const map) { char *method_name; I32 method_name_len; SV *method; HV *symbols; symbols = mop_get_all_package_symbols(stash, TYPE_FILTER_CODE); sv_2mortal((SV*)symbols); (void)hv_iterinit(map); while ((method = hv_iternextsv(map, &method_name, &method_name_len))) { SV *body; SV *stash_slot; if (!SvROK(method)) { continue; } if (sv_isobject(method)) { /* $method_object->body() */ body = mop_call0(aTHX_ method, KEY_FOR(body)); } else { body = method; } stash_slot = *hv_fetch(symbols, method_name, method_name_len, TRUE); if (SvROK(stash_slot) && ((CV*)SvRV(body)) == ((CV*)SvRV(stash_slot))) { continue; } /* delete $map->{$method_name} */ (void)hv_delete(map, method_name, method_name_len, G_DISCARD); } } MODULE = Class::MOP::Mixin::HasMethods PACKAGE = Class::MOP::Mixin::HasMethods PROTOTYPES: DISABLE void _method_map(self) SV *self PREINIT: HV *const obj = (HV *)SvRV(self); SV *const class_name = HeVAL( hv_fetch_ent(obj, KEY_FOR(package), 0, HASH_FOR(package)) ); HV *const stash = gv_stashsv(class_name, 0); UV current; SV *cache_flag; SV *map_ref; PPCODE: if (!stash) { mXPUSHs(newRV_noinc((SV *)newHV())); return; } current = mop_check_package_cache_flag(aTHX_ stash); cache_flag = HeVAL( hv_fetch_ent(obj, KEY_FOR(package_cache_flag), TRUE, HASH_FOR(package_cache_flag))); map_ref = HeVAL( hv_fetch_ent(obj, KEY_FOR(methods), TRUE, HASH_FOR(methods))); /* $self->{methods} does not yet exist (or got deleted) */ if ( !SvROK(map_ref) || SvTYPE(SvRV(map_ref)) != SVt_PVHV ) { SV *new_map_ref = newRV_noinc((SV *)newHV()); sv_2mortal(new_map_ref); sv_setsv(map_ref, new_map_ref); } if ( !SvOK(cache_flag) || SvUV(cache_flag) != current ) { mop_update_method_map(aTHX_ stash, (HV *)SvRV(map_ref)); sv_setuv(cache_flag, mop_check_package_cache_flag(aTHX_ stash)); /* update_cache_flag() */ } XPUSHs(map_ref); BOOT: mop_method_metaclass = newSVpvs("method_metaclass"); mop_associated_metaclass = newSVpvs("associated_metaclass"); mop_wrap = newSVpvs("wrap"); INSTALL_SIMPLE_READER(Mixin::HasMethods, method_metaclass); INSTALL_SIMPLE_READER(Mixin::HasMethods, wrapped_method_metaclass); release000755000767000024 012200352344 14247 5ustar00etherstaff000000000000Moose-2.1005/xteol.t100644000767000024 24012200352344 15327 0ustar00etherstaff000000000000Moose-2.1005/xt/releaseuse strict; use warnings; use Test::More; eval 'use Test::EOL'; plan skip_all => 'Test::EOL required' if $@; all_perl_files_ok({ trailing_whitespace => 1 }); Changes.Class-MOP100644000767000024 17310212200352344 15370 0ustar00etherstaff000000000000Moose-2.1005After 1.12, Class::MOP was merged into the Moose distribution, and is no longer released separately. 1.12 Mon, Jan 3, 2011 * Remove usage of undocumented Package::Stash APIs from the tests. This prevents the tests from failing on Package::Stash >= 0.18. 1.11 Sun, Oct 31, 2010 [ENHANCEMENTS] * Replace use of Test::Exception with Test::Fatal. (Karen Etheridge and Dave Rolsky) 1.10 Mon, Oct 18, 2010 [BUG FIXES] * Lots of fixes for edge cases with anon classes. (doy) 1.09 Tue, Oct 5, 2010 [ENHANCEMENTS] * It's now possible to tell Class::MOP::Class->create and the metaclass pragma to not install a 'meta' method into classes they manipulate, or to install one under a different name. (doy) * Reinitializing a metaclass no longer removes the existing method and attribute objects (it instead fixes them so they are correct for the reinitialized metaclass). (doy) * All 'meta' methods created by Class::MOP are now of the class Class::MOP::Method::Meta. This is overridable at the metaclass layer. (doy) [OTHER] * Use get_or_add_package_symbol when we intend for it to autovivify, in preparation for changes in Package::Stash. (doy) * We now use Module::Install::AuthorRequires to force authors to run all tests, just like we do for Moose. (sartak) 1.08 Mon, Sep 13, 2010 [BUG FIXES] * The get_method_list and _get_local_methods methods blew up in the face of subroutine stubs. (Goro Fuji) 1.07 Tue, Aug 25, 2010 [BUG FIXES] * Fix a mysterious error reported by Piers Cawley. The error showed up as "Can't use an undefined value as a symbol reference at /usr/local/lib/perl/5.10.1/Class/MOP/Mixin/HasMethods.pm line 167." (Dave Rolsky) 1.06 Sun, Aug 23, 2010 [BUG FIXES] * Version 1.05 no longer reported constants as methods, except with Perl 5.8.x, and doing so in 5.8.x caused test failures. Constants are now _expected_ to be reported as methods, and we explicitly test this. (Dave Rolsky) 1.05 Sun, Aug 22, 2010 [ENHANCEMENTS] * Refactorings and improvements to how defaults are handled, particularly for inlined code (doy). * Optimizations that should help speed up compilation time (Dave Rolsky). 1.04 Tue, Jul 25, 2010 [ENHANCEMENTS] * Class::MOP::Deprecated now uses Package::DeprecationManager internally. Deprecation warnings are now only issued once for each calling package, which cuts down on noise. When importing Class::MOP::Deprecated, the request API version should now be passed in the "-api_version" flag. However, the old "-compatible" flag will continue to work. (Dave Rolsky) 1.03 Sat, Jun 5, 2010 [ENHANCEMENTS] * Make CMOP::Package a thin wrapper around Package::Stash (doy). 1.02 Thu, May 20, 2010 [API CHANGES] * Packages and modules no longer have methods - this functionality was moved back up into Class::MOP::Class (doy). [ENHANCEMENTS] * Metaclass incompatibility checking now checks all metaclass types. (doy) * Class::MOP can now do simple metaclass incompatibility fixing: if your class's metaclass is a subclass of your parent class's metaclass, it will just use the parent class's metaclass directly. (doy) 1.01 Thu, May 6, 2010 [NEW FEATURES] * is_class_loaded, load_class and load_first_existing_class now allow specifying a minimum required version (Florian Ragwitz). [BUG FIXES] * The __INSTANCE__ parameter to Class::MOP::Class::new_object now enforces that the passed in reference is blessed into the correct class (by dying if it's not) (doy, jhallock). 1.00 Thu, Mar 25, 2010 [GRRR< FUCKING STEVAN@] * Re-release 0.99 as 1.00. 0.99 Thu, Mar 25, 2010 [DOCUMENTATION] * Fix typo in Class::MOP::Attribute (Franck Cuny). 0.98 Mon, Jan 18, 2010 [ENHANCEMENTS] * Added Class::MOP::Class->rebless_instance_back, which does the inverse of rebless_instance (doy, rafl). 0.97_01 Mon, Jan 4, 2010 [ENHANCEMENTS] * Internal refactorings to move shared behavior into new "mixin" classes. This made adding some new features to Moose much easier. (Dave Rolsky) 0.97 Fri, Dec 18, 2009 * No code changes, just packaging fixes to make this distro installable. 0.96 Fri, Dec 18, 2009 * tests - Fixed t/082_get_code_info.t so it passes with bleadperl. (Dave Rolsky) - Add XS & C files to no tabs check (Dave Rolsky) - Convert all tests to done_testing. (Florian Ragwitz) 0.95 Wed, Nov 19, 2009 * Class::MOP - Make is_class_loaded without any arguments fail loudly (Florian Ragwitz). - Make load_class throw more standard error messages when loading single modules (nothingmuch). * Class::MOP::Package - Stop add_method from behaving differently under the debugger (Florian Ragwitz). * Class::MOP::Class * Class::MOP::Package - Any method which takes a method name as an argument now allows names which are false (like "0"), but the name must be defined and not be an empty string. (Dave Rolsky) * Class::MOP::Class - Deprecated get_attribute_map as a public method. You can use a combination of get_attribute_list and get_attribute instead. (Dave Rolsky) 0.94 Tue, Sep 22, 2009 * Class::MOP::Attribute - Introduce set_raw_value and get_raw_value, side effect free variants of {get,set}_value. These don't do anything useful in Class::MOP but have different behavior that set_value and get_value for Moose attributes. (nothingmuch) 0.93 Tue, Sep 15, 2009 * Class::MOP - The load_class function just returns true, since it's return value was confusing (either a metaclass object or a class name). It either loads a class or dies trying. In the future, this may change to not return anything, since there's no point in checking its return value. Addresses RT #45883. (Dave Rolsky) * Class::MOP::Class::Trait::Immutable - When throwing an error because of an immutable method, include that method's name. Addresses RT #49680. (Shawn M Moore) * Class::MOP::Package - Adding the same sub reference to multiple packages failed to update the method map properly. RT #48985. Reported by Paul Mooney. (Dave Rolsky) - The get_method_map method is now private (and called as _full_method_map or _method_map). The public version is available as a deprecated method. (Dave Rolsky) 0.92_01 Thu, Sep 10, 2009 * Class::MOP::Package - Backwards compatibility tweaks to XS for 5.8.1. (Goro Fuji) * Class::MOP - Make sure XS code handles magical scalars correctly. (Goro Fuji) * Class::MOP::Class - Documented the immutable_options method, which is useful if you need to make a class mutable temporarily, and then nede to restore immutability. (Dave Rolsky) * Many modules - Deprecated features have been moved to their own module, Class::MOP::Deprecated, for easier deprecation management. (Goro Fuji) 0.92 Thu Aug 13, 2009 * Class::MOP::Class * Class::MOP::Package - Move get_method_map and its various scaffolding into Package. (hdp) * Class::MOP::Method - Allow Class::MOP::Method->wrap to take a Class::MOP::Method object as the first argument, rather than just a coderef. (doy) * Class::MOP::Attribute * Class::MOP::Class - Allow attribute names to be false (while still requiring them to be defined). (rafl) 0.91 Wed Jul 29, 2009 * Class::MOP::Method::Wrapped - Fixing variable usage issues with the patch from previous version, not properly using lexicals in the for loops. (stevan) 0.90 Tue Jul 21, 2009 Japan Perl Association has sponsored Goro Fuji to improve startup performance of Class::MOP and Moose. These enhancements may break backwards compatibility if you're doing (or using) complex metaprogramming, so, as always, test your code! http://blog.perlassociation.org/2009/07/jpa-sponsors-moose-class-mop-work.html * Class::MOP::Class * XS - Anonymous classes were not completely destroyed when they went out of scope, leading to a memory leak. RT #47480. (Goro Fuji). * Class::MOP::Class - The get_method, has_method, and add_method methods no longer use get_method_map. Method objects are instantiated lazily. This significantly improves Class::MOP's load time. (Goro Fuji) * All classes - Inline fewer metaclass-level constructors since the ones we have are perfectly fine. This reduces the number of string evals. (Goro Fuji) * Class::MOP::Method::Wrapped - If a method modifier set $_, this caused the modifier to blow up, because of some weird internals. (Jeremy Stashewsky) 0.89 Fri Jul 3, 2009 * Class::MOP::Class * Class::MOP::Class::Immutable::Trait - Made the Trait act like a role with a bunch of "around" modifiers, rather than sticking it in the inheritance hierarchy. This fixes various problems that caused with metaclass compatibility, which broke Fey::ORM. * Class::MOP::Method - Allow a blessed code reference as the method body. Fixes a problem interaction with MooseX::Types. (ash) * Class::MOP::Instance - add inline version of rebless_instance_structure. (doy) - change inline_slot_access to use single quotes (gphat) 0.88 Tue, Jun 23, 2009 * Class::MOP::Class - Moved the __INSTANCE__ parameter to _construct_instance from Moose to here. (doy) - Fixed some issues involving metaclasses of metaclasses and immutability. (doy) 0.87 Sun, Jun 21, 2009 * Various - Made sure to always local-ize $@ and $SIG{__DIE__} before calling an eval. Fixes RT #45973. * Class::MOP::Class - Synced docs about immutability with the current reality (which changed back in 0.82_01) - Removed the immutable_transformer method, which had been returning undef since 0.82_01 anyway. * Tests - Got rid of tests which needed Moose and improved testing of constructor/destructor inlining warnings. Fixes RT #47119. 0.86 Tue, Jun 16, 2009 * Class::MOP::Class - If you redefined a subroutine at runtime and then wrapped it with a method modifier, the modifier could in some cases wrap the original version of the subroutine. Fixes RT #46957. * Class::MOP::Class - make_immutable issues a warning instead of overriding an existing DESTROY method (Dylan William Hardison). Fixes RT #46854. 0.85 Sat, Jun 6, 2009 * Class::MOP::Attribute - Allow default values to be Class::MOP::Methods. (Florian Ragwitz) - Test the above. (Rhesa Rozendaal) - Tweak original commit so the intent matches the accepted behavior (Nicholas Perez) * Class::MOP - Localize $SIG{__DIE__} inside _try_load_one_class (Sartak) * Class::MOP::Class - Add direct_subclasses method (Sartak) - Tests for subclasses and direct_subclasses (Sartak) - subname is no longer used unconditionally in add_method, but only if the code reference's name is '__ANON__' (nothingmuch) - Add a hook for _superclasses_updated (Sartak) * Class::MOP::Method - Remove long, old warning about possibly outdated modules (Sartak) 0.84 Tue, May 12, 2009 * Makefile.PL - Depend on Text::Exception 0.27 to avoid failing tests ond old versions (rafl) * Class::MOP - Made is_class_loaded a little stricter. It was reporting that a class was loaded if it merely had an @ISA variable in its stash. Now it checks that the @ISA var has elements in it. - Deprecate in_global_destruction and subname re-exporting (perigrin & Sartak) * Class::MOP::Class - Explicitly use Devel::GlobalDestruction and Sub::Name (perigrin) * Class::MOP::Package - Disable prototype mismatch warnings for add_package_symbol. (Florian Ragwitz) * Tests - Add test for finding methods from $meta->name->meta before immutable, (t0m) 0.83 Mon, April 27, 2009 * Class::MOP::Class - Fix segfault when calling get_method_map on a metaclass for an empty package (doy) 0.82_02 Fri, April 24, 2009 * Class::MOP::Method::Inlined - Don't inline if the expected method is not defined at all (happens with e.g. Moose::Object::_new is the expected method due to an overridden name) * Tests - Some tests were trying to load Class::MOP::Immutable, which was removed in 0.82_01. 0.82_01 Thu, April 23, 2009 * Class::MOP::Immutable (and others) - Refactor the immutability system to use a pre-defined class for the immutable metaclass of Class::MOP::Class::Immutable::$class - Rather than generating methods into this class every time, use a Trait (basic mixin) to supply the cached methods - Remove the hack that returns the mutable metaclass for metacircularity in order to provide consistent meta-metaclasses for the Moose compatibility handling code (mst broke it, nothingmuch fixed it) 0.82 Mon, April 20, 2009 * Various - The deprecation wrappers for some renamed methods were not passing arguments to the new method. (nothingmuch) * Class::MOP::Immutable - Warn during immutablization if the local class provides its own constructor, to parallel the warning in Moose when a superclass provides its own constructor (doy) 0.81 Tue, April 7, 2009 * Class::MOP * Class::MOP::Class * Class::MOP::Instance * Class::MOP::Attribute * Class::MOP::Method::Accessor * Class::MOP::Method::Constructor - Include stack traces in the deprecation warnings introduced in 0.80_01. (Florian Ragwitz) * MOP.xs - Avoid c compiler warnings by declaring some unused function arguments. (Florian Ragwitz) 0.80_01 Sun, April 5, 2009 * Makefile.PL - Make sure to preserve any compiler flags already defined in Config.pm. Patch by Vincent Pit. RT #44739. * Many methods have been renamed with a leading underscore, and a few have been deprecated entirely. The methods with a leading underscore are considered "internals only". People writing subclasses or extensions to Class::MOP should feel free to override them, but they are not for "public" use. - Class::MOP::Class - construct_class_instance => _construct_class_instance (use new_object) - construct_instance => _construct_instance (use new_object) - check_metaclass_compatibility => _check_metaclass_compatibility - create_meta_instance => _create_meta_instance (use get_meta_instance) - clone_instance => _clone_instance (use clone_object) - compute_all_applicable_methods is deprecated, use get_all_methods - compute_all_applicable_attributes is deprecated, use get_all_attributes - Class::MOP::Instance - bless_instance_structure is deprecated and will be removed in a future release - Class::MOP::Module - create has been renamed to _instantiate_module. This method does not construct an object, it evals some code that creates the relevant package in Perl's symbol table. - Class::MOP::Method::Accessor - initialize_body => _initialize_body (this is always called when an object is constructed) - /(generate_.*_method(?:_inline)?)/ => '_' . $1 - Class::MOP::Method::Constructor - initialize_body => _initialize_body (this is always called when an object is constructed) - /(generate_constructor_method(?:_inline)?)/ => '_' . $1 - attributes => _attributes - meta_instance => _meta_instance 0.80 Wed, April 1, 2009 * Class::MOP::* - Call user_class->meta in fewer places, with the eventual goal of allowing the user to rename or exclude ->meta altogether. Instead uses Class::MOP::class_of. (Sartak) * Class::MOP - New class_of function that should be used to retrieve a metaclass. This is unlike get_metaclass_by_name in that it accepts instances, not just class names. (Sartak) * Class::MOP - load_first_existing_class didn't actually load the first existing class; instead, it loaded the first existing and compiling class. It now throws an error if a class exists (in @INC) but fails to compile. (hdp) * Class::MOP * Class::MOP::Class - we had some semi-buggy code that purported to provide a HAS_ISAREV based on whether mro had get_isarev (due to an oversight, it always returned 1). Since mro and MRO::Compat have always had get_isarev, HAS_ISAREV was pointless. This insight simplified the subclasses method by deleting the pure-perl fallback. HAS_ISAREV is now deprecated. (Sartak) 0.79 Fri, March 29, 2009 * No changes from 0.78_02. 0.78_02 Thu, March 26, 2009 * Class::MOP::Class * Class::MOP::Immutable - A big backwards-incompatible refactoring of the Immutable API, and the make_immutable/make_mutable pieces of the Class API. The core __PACKAGE__->meta->make_immutable API remains the same, however, so this should only affect the most guts-digging code. * XS code - The XS code used a macro, XSPROTO, that's only in 5.10.x. This has been fixed to be backwards compatible with 5.8.x. * Class::MOP::Class - Add a hook for rebless_instance_away (Sartak) - Use blessed instead of ref to get an instance's class name in rebless_instance. (Sartak) 0.78_01 Wed, March 18, 2009 * Class::MOP::* - Revised and reorganized all of the API documentation. All classes now have (more or less) complete API documentation. * Class::MOP::Class * Class::MOP::Instance - Reblessing into a package that supports overloading wasn't properly adding overload magic to the object due to a bug in (at least) 5.8.8. We now use $_[1] directly which seems to set the magic properly. (Sartak) * Class::MOP::Attribute - The process_accessors method is now private. A public alias exists (and will stick around for a few releases), but it warns that calling the public method is deprecated. * Class::MOP::Method::Generated - Removed the new and _new methods, since this is an abstract base class, and all existing subclasses implement their own constructors. * MOP.xs - Stop is_class_loaded from thinking a class is loaded if it only has an empty GV (Florian Ragwitz). - Add a test for this (Yappo). - Refactor get_all_package_symbols to allow short-circuiting (Florian Ragwitz). - Use this in is_class_loaded (Florian Ragwitz). - Stop segfaulting when trying to get the name from a sub that's still being compiled (Florian Ragwitz). - Add tests for this (Florian Ragwitz). - Prefix all public symbols with "mop_" (Florian Ragwitz). - Clean up and simplify prehashing of hash keys (Florian Ragwitz). - Simplify creating simple xs reader methods (Florian Ragwitz). - Make everything compile with c++ compilers (Florian Ragwitz). - Upgrade ppport.h from 3.14 to 3.17 (Florian Ragwitz). * Tests - Remove optional test plans for tests depending on Sub::Name as we have a hard dependency on Sub::Name anyway (Florian Ragwitz). * Makefile.PL - Rebuild all c code if mop.h has changed (Florian Ragwitz) 0.78 Mon, February 23, 2009 * No changes from 0.77_01 0.77_01 Sun, February 22, 2009 * Everything - This package now requires its XS components. Not using Sub::Name lead to different behavior and bugginess in the pure Perl version of the code. A Moose test would fail when run against the pure Perl version of this code. * Class::MOP::Instance - The inline_* methods now quote attribute names themselves, and don't expect to receive a quoted value. 0.77 Sat, February 14, 2009 * MOP.xs - Avoid assertion errors on debugging perls in is_class_loaded (Florian Ragwitz) * Class::MOP - Fixed various corner cases where is_class_loaded incorrectly returned true for a class that wasn't really loaded. (Dave Rolsky) * Class::MOP::Class - Add get_all_method_names (Sartak) - Add a wrapped_method_metaclass attribute (Florian Ragwitz) * Class::MOP::Package - Disable deprecated get_all_package_symbols in list context. (Florian Ragwitz) * Makefile.PL - Make sure we generate a BSD-compatible Makefile (Florian Ragwitz) * Class::MOP::Class - The misspelled "check_metaclass_compatability" method we've kept around for backwards compat_i_bility will be removed in a near future release. You've been warned. 0.76 Thu, January 22, 2009 * Class::MOP::Method::Generated - Added new private methods to support code generation, which are being used by Moose and can be used by MooseX authors. (mst) - Generated methods are now generated with a #line directive reflecting the source of the generated method. (nothingmuch) * Class::MOP::Class - Clarified documentation of methods that return Class::MOP::Method objects. (doy) * Class::MOP - Clarified documentation of the metaclass cache methods. (Sartak) * Tests - Add test showing how the xs Class::MOP::is_class_loaded can be made to operate differently to the pure perl version (t0m) 0.75 Wed, December 31, 2008 * Class::MOP::Class - A class that was made immutable and then mutable could end up sharing an immutable transformer object (Class::MOP::Immutable) with other classes, leading to all sorts of odd bugs. Reported by t0m. (Dave Rolsky) 0.74 Tue, December 25, 2008 * MOP.xs - Add an xs implementation of Class::MOP::is_class_loaded (closes RT#41862). Based on a patch by Goro Fuji. (Florian Ragwitz) - Changed internals to make prehashing of hash keys easier and less error-prone. (Florian Ragwitz) * Class::MOP::Class - Fix documentation to show that around modifiers happen on both sides of the modified method. (Dave Rolsky) 0.73 Tue, December 16, 2008 * MOP.xs - Don't use Perl_mro_meta_init. It's not part of the public perl api. Fixes failures to build on Win32 (RT #41750). (Florian Ragwitz) * t/082_get_code_info.t - Add $^P &= ~0x200; (per Ovid's suggestion) in order to not munger anonymous subs when under -d and so making the tests succeed in that case. 0.72 Mon, December 8, 2008 * Class::MOP::Package - Pass options to _new, so subclass' attributes can be initialized (Sartak) * Class::MOP::Method - In the docs, indicate that package_name and name are required when calling ->wrap (Stefan O'Rear) 0.71_02 Fri, December 5, 2008 * Class::MOP::Immutable - Added a new attribute, inlined_constructor, which is true if the constructor was inlined. * Class::MOP::Package - Make get_all_package_symbols return a hash ref in scalar context and deprecate calling it in list context with a warning. (Florian Ragwitz) * MOP.xs - Various improvements and refactoring, making things more robust and easier to maintain. (Florian Ragwitz) 0.71_01 Wed, December 3, 2008 * Class::MOP::Method - Add an "execute" method to invoke the body so we can avoid using the coderef overload (Sartak) * Class::MOP::Immutable - When we memoize methods, get their results lazily to remove some compile-time cost (Sartak) - Small speedup from eliminating several method calls (Sartak) * Class::MOP::Class - Some small internal tweaks to try to reduce the number of times we call get_method_map when bootstrapping the MOP. This might make loading Class::MOP (and Moose) a little faster. (Dave Rolsky) - Implemented an optional XS version of get_method_map. Mostly taken from a patch by Goro Fuji (rt.cpan.org #41080), with help form Florian Ragwitz. (Dave Rolsky) - Make the behaviour of of get_all_package_symbols (and therefore get_method_map) consistent for stub methods. Report and test by Goro Fuji (rt.cpan.org #41255). (Florian Ragwitz) 0.71 Wed November 26, 2008 * Class::MOP::Class * Class::MOP::Module - Actual package creation has moved upward from Class to Module so that Moose roles can share the code (Sartak) 0.70_01 Mon, November 19, 2008 * Class::MOP - Fixes for failures with blead (Florian Ragwitz) - Silenced compiler warnings (Florian Ragwitz) 0.70 Fri, November 14, 2008 * Class::MOP - Fixed an odd corner case where the XS version of get_all_package_symbols could cause a segfault. This only happened with inlined constants in Perl 5.10.0 (Florian Ragwitz) 0.69 Fri, November 7, 2008 * Class::MOP::Method::Wrapped - Added introspection methods for method modifiers (Dave Rolsky) 0.68 Fri October 24, 2008 * Class::MOP - Make load_class require by file name instead of module name. This stops confusing error messages when loading '__PACKAGE__'. (Florian Ragwitz) - Add load_one_class_of function to enable you to load one of a list of classes, rather than having to call load_class multiple times in an eval. (t0m) 0.67 Tue October 14, 2008 * Class::MOP::Class - Call a method on the class after setting the superclass list so that we can get Perl to detect cycles before MRO::Compat spirals into an infinite loop (sartak) - Reported by Schwern, [rt.cpan.org #39001] - In create(), pass unused options on to initialize() - added test for this 0.66 Sat September 20, 2008 !! This release has an incompatible change regarding !! introspection of a class's method with Class::MOP::Class !! * Tests and XS - We (us maintainers) now run all tests with XS and then without XS, which should help us catch skew between the XS/pure Perl code. (Dave Rolsky) * Class::MOP::Class ! The alias_method method has been deprecated. It now simply calls add_method instead. There is no distinction between aliased methods and "real" methods. This means that methods added via alias_method now show up as part of the class's method list/map. This is a backwards incompatible change, but seems unlikely to break any code. Famous last words. (Dave Rolsky) * Class::MOP::Class - Fixed the spelling of "compatibility", but we still have a "check_metaclass_compatability" method for backwards compatibility. 0.65 Mon September 1, 2008 For those not following the series of dev releases, the changes from 0.64 from 0.65 can mostly be summed up as a lot performance improvements by nothingmuch, including new optional XS versions of some methods. Also, Class::MOP now works _without_ any XS modules, for sad systems without a compiler. * Class::MOP::Method - Added name and package_name XS accessors, and make sure all the XS and Perl versions work the same way. (Dave Rolsky) * MOP.xs - The XS versions of various methods just returned undef when called class methods, rather than dying like the pure Perl versions. (Dave Rolsky) 0.64_07 Fri August 29, 2008 * Class::MOP - Silenced warnings that managed to break Moose tests when XS was loaded. (Dave Rolsky) - Some XS versions of methods were ignored because of typos in MOP.xs. (Dave Rolsky) 0.64_06 Mon August 25, 2008 * Class::MOP (MOP.xs) - Another MS VC++ fix, cannot declare a variable in the middle of a scope (Taro Nishino). 0.64_05 Sun August 24, 2008 * Class::MOP - None of the dev releases actually loaded the XS properly, but we silently fell back to the pure Perl version of the code. (Dave Rolsky) * Class::MOP (MOP.xs) - Replaced some code that used functions not available on Visual C++ with some Perl XS API bits (Dave Rolsky). 0.64_04 Sat August 23, 2008 * Class::MOP::Class - Workaround a bug in 5.8.1's goto sub (nothingmuch) * pod.t and pod_coveraget.t - These are no longer shipped with the tarball because of bogus failures from CPAN testers. (Dave Rolsky) 0.64_03 Thu August 21, 2008 * Class::MOP::Package - Some (legit) code was misparsed by earlier 5.8.x releases. (nothingmuch) * Class::MOP - Fix a constant in void context warning (nothingmuch) 0.64_02 Thu August 21, 2008 * Makefile.PL and Class::MOP - Explicitly require Perl 5.8.0+ (Dave Rolsky) * Makefile.PL - Add missing prereqs that got lost in the switch away from Module::Install. * Class::MOP::Instance - New method - get_all_attributes (nothingmuch) 0.64_01 Wed August 20, 2008 * Makefile.PL - We now check to see if you have a compiler. If you don't, the module installs without some XS bits, but will work the same as with XS. This should make it easier to install on platforms without a compiler (like Windows). (Dave Rolsky) * many modules - Perl 6 style attribute naming replaced with sane style ('methods', not '%!methods'). These changes should not impact any existing API uses. (nothingmuch). * many modules - Quite a number of optimizations based on profiling, including allowing constructors to take hash references instead of hashes, duplicating some frequently used code in XS, and making constructors immutable. These changes should not impact any existing API uses. (nothingmuch) * Many modules - Constructors now respect the meta attributes of their subclasses, facilitating MOP extensibility. More related changes will happen in the next several releases. (nothingmuch) * Class::MOP::Class - New method - get_all_methods, replaces the deprecated compute_all_applicable_methods. get_all_attributes provided for consistency (nothingmuch) - New method - wrap_method was refactored out of get_method_map (nothingmuch) - New API for meta instance invalidation - invalidate_meta_instance, invalidate_meta_instances, add_dependent_meta_instance, remove_dependent_meta_instance, called automatically when attribute definitions change and allows notification of dependent subclasses. (nothingmuch) 0.64 Sun August 3, 2008 * Class::MOP::Immutable - fixing subtle edge case in immutable when you call ->meta (stevan) - clean up option processing (nothingmuch) * Class::MOP::Instance - inlined initialize slot didn't match non-inlined (nothingmuch) 0.63 Mon July 7, 2008 * Class::MOP - load_class will initialize a metaclass even if the class is already loaded (sartak) - load_class now returns the metaclass instance instead of just 1 (sartak) * elsewhere - better error messages (sartak and Dave Rolsky) 0.62 Wed June 18, 2008 - in is_class_loaded, recognize scalar references (as opposed to globs) in the symbol table as methods (these are optimized constant subs) 0.61 Fri. June 13, 2008 - Okay, lets give this another try and see if PAUSE recognizes it correct this time. 0.60 Thurs. Jun 12, 2008 - Fixed a version number issue by bumping all modules to 0.60. 0.59 Thurs. Jun 12, 2008 !! Several fixes resulting in yet another 25-30% speedup !! * Class::MOP::Class - now stores the instance of the instance metaclass to avoid needless recomputation and deletes it when the cache is blown - introduce methods to query Class::MOP::Class for the options used to make it immutable as well as the proper immutable transformer. (groditi) * Class::MOP::Package - {add, has, get, remove}_package_symbol all now accept a HASH ref argument as well as the string. All internal usages now use the HASH ref version. * Class::MOP - MOP.xs does sanity checks on the coderef to avoid a segfault - is_class_loaded check now uses code that was improved in Moose's ClassName type check (Sartak) - nonsensical (undef, empty, reference) class names now throw a more direct error in load_class (Sartak) - tests for this and other aspects of load_class (Sartak) * Class::MOP Class::MOP::Class Class::MOP::Method Class::MOP::Method::Wrapped Class::MOP::Attribute - switched usage of reftype to ref because it is much faster 0.58 Thurs. May 29, 2008 (late night release engineering)-- - fixing the version is META.yml, no functional changes in this release 0.57 Wed. May 28, 2008 !! Several speedups resulting in 20-25% speedups !! || (thanks to konobi, groditi, mst & CataMoose) !! * Class::MOP::Class - made get_method_map use list_all_package_symbols instead of manually grabbing each symbol - streamlining &initialize somewhat, since it gets called so much * Class::MOP::Package - made {get, has}_package_symbol not call &namespace so much - inlining a few calls to &name with direct HASH access key access - added get_all_package_symbols to fetch a HASH of items based on a type filter similar to list_all_package_symbols - added tests for this * Class::MOP::Method Class::MOP::Method::Constructor Class::MOP::Method::Generated Class::MOP::Method::Accessor - added more descriptive error message to help keep people from wasting time tracking an error that is easily fixed by upgrading. * Class::MOP::Immutable - Don't inline a destructor unless the user actually needs one - added tests for this 0.56 Saturday, May 24, 2008 * Class::MOP - we now get the &check_package_cache_flag function from MRO::Compat - All XS based functionality now has a Pure Perl alternative - the CLASS_MOP_NO_XS environment variable can now be used to force non-XS versions to always be used * Class::MOP::Attribute - add has_read_method and has_write_method - get_{read,write}_method_ref now wraps the anon-sub ref in the method metaclass when possible - added tests for this * Class::MOP::Immutable - added the ability to "wrap" methods when making the class immutable * Class::MOP::Class - now handling the edge case of ->meta->identifier dying by wrapping add_package_symbol to specifically allow for it to work. - added tests for this * Class::MOP::Attribute Class::MOP::Class Class::MOP::Immutable - any time a method meta object is constructed we make sure to pass the correct package and method name information * Class::MOP::Method Class::MOP::Method::Wrapped Class::MOP::Method::Generated Class::MOP::Method::Accessor Class::MOP::Method::Consructor - the &wrap constructor method now requires that a 'package_name' and 'name' attribute are passed. This is to help support the no-XS version, and will throw an error if these are not supplied. - all these classes are now bootstrapped properly and now store the package_name and name attributes correctly as well ~ Build.PL has been removed since the Module::Install support has been removed 0.55 Mon. April 28, 2008 - All classes now have proper C3 MRO support - added MRO::Compat as a dependency to allow for the C3 MRO support to Just Work in all perl versions * Class::MOP::Class - rebless_instance now returns the instance it has just blessed, this is mostly to facilitate chaining - set the attr correctly in rebless_instance when it has no init_arg - tweaked &linear_isa and &class_precedence_list to support c3 classes. 0.54 Fri. March, 14, 2008 * Class::MOP metaclass.pm - making sure that load_class never gets passed a value from @_ or $_ to squash Ovid's bug (http://use.perl.org/~Ovid/journal/35763) * Class::MOP::Class - make_{immutable,mutable} now return 1 (cause Sartak asked) - improved error handling in ->create method - rebless_instance now takes extra params which will be used to populate values - added tests for this * Class::MOP::Object - localizing the Data::Dumper configurations so that it does not pollute others (RT #33509) * Class::MOP::Class Class::MOP::Package Class::MOP::Module Class::MOP::Method Class::MOP::Attribute - these classes no longer define their own ->meta, but instead just inherit from Class::MOP::Object * Class::MOP::Instance Class::MOP::Immutable - these classes now inherit from Class::MOP::Object * t/ - fixed the filename length on several test files so we install on VMS better (RT #32295) - fixed incorrect use of catdir when it should be catfile (RT #32385) 0.53 Thurs. Feb. 14, 1008 ~~ several doc. fixes and updates ~~ * Class::MOP::Class Class::MOP::Method::Constructor Class::MOP::Attribute - making init_arg accept an undefined value to indicate that no constructor args can be passed (thanks to nothingmuch) - added tests for this - added attribute initializer attribute (rjbs) * Class::MOP. - making this use the new init_arg => undef feature instead of the silly hack from before (thanks to nothingmuch) 0.52 Tues. Jan. 22, 2008 * Class::MOP::Class - fixed bug in rebless_instance (discovered by ash) * Class::MOP::Method::Constructor - removed assumptions about the existence of a &meta method 0.51 Mon. Jan. 14, 2008 ~~~ some misc. doc. fixes ~~~ ~~ updated copyright dates ~~ * Class::MOP - now sets the IS_RUNNING_ON_5_10 constant so that we can take advantage of some of the nice bits of 5.10 * Class::MOP::Class - uses the IS_RUNNING_ON_5_10 flag to optimize the &linearized_isa method and avoid the hack/check for circular inheritence in &class_precedence_list - added rebless_instance method (Sartak) - added tests for this * Class::MOP::Immutable - the immutable class now keeps track of the transformer which immutablized it * Class::MOP::Instance - added rebless_instance_structure method (Sartak) - added tests for this 0.50 Fri. Dec. 21, 2007 * Class::MOP::Class - fixed bug in immutable to make sure that transformation arguments are saved correctly (mst) - added tests for this * Class::MOP::Immutable - fixed a bug (see above) * Class::MOP::Attribute - some doc updates 0.49 Fri. Dec. 14, 2007 !! Class::MOP now loads 2 x faster !! !! with XS speedups (thanks konobi) !! * Class::MOP - removed the dependency on B - added two XS functions (thanks konobi) - get_code_info($code) which replaces all the B fiddling we were doing with faster/leaner XS level fiddling - check_package_cache_flag($pkg_name) which returns the PL_sub_generation variable to be used to help manage method caching. NOTE: In 5.10 or greater this will actually use the mro::get_pkg_gen instead to give even more accurate caching information. blblack++ for that stuff :) * Class::MOP::Class - added the &subclasses method (thanks rlb) - added the update_package_cache_flag and reset_package_cache_flag which help keep track of when we need to re-fetch the method map. - Several small improvements to take advantage of the new method map caching features 0.48 Mon. Nov. 26, 2007 * Class::MOP::Attribute - fixed get_read/write_method to handle the HASH ref case, which makes the get_read/write_method_ref handle it too. - added more tests for this 0.47 Sat. Nov. 24, 2007 * Class::MOP::Attribute - fixed misspelling in get_write_method_ref - added more tests for this 0.46 Fri. Nov. 23, 2007 * Class::MOP::Class - added the linearized_isa method instead of constantly pruning duplicate classes (this will be even more useful in the 5.10-compat version coming soon) * Class::MOP::Attribute - added the get_read_method_ref and get_write_method_ref methods which allow you to retrieve a CODE ref which can always be used to read or write an attribute. 0.45 Thurs. Nov. 13, 2007 * Class::MOP::Attribute - Fix error message on confess (groditi) 0.44 Thurs. Nov. 13, 2007 - Apparently I didn't make dist correctly (groditi) 0.43 Thurs. Nov. 13, 2007 * Class::MOP - Add support for the 'builder' attribute (groditi) * Class::MOP::Class - optimise metaclass-already-exists check in construct_class_instance (groditi) - duplicate check into initialize to save a call through (groditi) * Class::MOP::Attribute - Add support for the 'builder' attribute (groditi) - Make predicates check for the existence of a value, not whether it is defined (groditi) * Class::MOP::Instance - Make predicates check for the existence of a value, not whether it is defined (groditi) * Class::MOP::Method::Accessor - made this a subclass of Class::MOP::Method::Generated - removed the relevant attributes * Class::MOP::Method::Constructor - fixed the cached values we had to be more sane - made this a subclass of Class::MOP::Method::Generated - fixed generated constructor so it properly handles subclasses now. - added tests for this - added the option to allow for both inlined and non-inlined constructors. - Update inlined methods for builder and predicate changes (groditi) * Class::MOP::Method::Generated - added this class as an abstract base for the Class::MOP::Method::{Constructor,Accessor} classes - added tests for this *t/ - Alter tests (005, 014 020, 021) for new builder addition (groditi) - Tests for new predicate behavior (and corrections to old tests) (groditi) *examples/ - Update ArrayRef based class example to work with predicate changes 0.42 Mon. July 16, 2007 !!! Horray for mst, he fixed it !!! * Class::MOP::Package - alter symbol table handling to deal with 5.8.x and 5.9.x * t/ - Get rid of the crappy workaround from 0.40/41 0.41 Sun. July 15, 2007 * t/ Arghh!!! My TODO test didn't work, so I handle it manually now so that people can use this with 5.9.5/bleadperl without issue. 0.40 Tues, July 3, 2007 * t/ ~ marked a test in 003_methods.t as TODO for perl 5.9.5 (this test is irrelvant to the module functioning on 5.9.5 for the most part anyway) 0.39 Mon. June 18, 2007 * Class::MOP::Immutable - added make_metaclass_mutable + docs (groditi) - removed unused variable - added create_immutable_transformer necessary for sane overloading of immutable behavior - tests for this (groditi) * Class::MOP::Class - Immutability can now be undone, added make_mutable + tests + docs (groditi) - Massive changes to the way Immutable is done for details see comments next to make_immutable This fixes a bug where custom metaclasses broke when made immutable. We are now keeping one immutable metaclass instance per metaclass instead of just one to prevent isa hierarchy corruption. Memory use will go up, but I suspect it will be neglible. - New tests added for this behavior. (groditi) 0.38 Thurs. May 31, 2007 ~~ More documentation updates ~~ * Class::MOP::Package - we now deal with stub methods properly - added tests for this - fixed some tests failing on 5.9.5 (thanks blblack) * Class::MOP::Attribute - added get_read_method and get_write_method thanks to groditi for this code, tests and docs. - added tests and POD for this * Class::MOP::Class - fixed RT issue #27329, clone object now handles undef values correctly. - added tests for this - Corrected anon-class handling so that they will not get reaped when instances still exist which need to reference them. This is the correct behavior, hopefully this is an obscure enough feature that there are not too many work arounds out in the wild. - added tests for this by groditi - updated docs to explain this * metaclass - load custom metaclasses automatically (thanks groditi) - added tests for this behavior 0.37 Sat. March 10, 2007 ~~ Many, many documentation updates ~~ * Class::MOP - added &load_class and &is_class_loaded - added tests and docs for these * Class::MOP::Attribute - default now checks the instance with defined to avoid setting off bool-overloads (found by Carl Franks) 0.37_002 * /t - bad name in a test, causing meaningless failuress. No other changes. 0.37_001 ~~ GLOBAL CHANGES ~~ - All attribute names are now consistent and follow Perl 6 style (prefixed with the sigil, and ! as the twigil for private attrs). This should not affect any code, unless you broke encapsulation, in which case, it is your problem anyway. !! Class::MOP::Class::Immutable has been removed * Class::MOP::Method::Constructor - this has been moved out of Class::MOP::Class::Immutable and is a proper subclass of Class::MOP::Method now. * Class::MOP::Class - this module now uses Class::MOP::Immutable for the immutable transformation instead of Class::MOP::Class::Immutable. + Class::MOP::Immutable - this module now controls the transformation from a mutable to an immutable version of the class. Docs for this will be coming eventually. 0.36 Sun. Nov. 5, 2006 * Class::MOP::Class - added a few 'no warnings' lines to keep annoying (and meaningless) warnings from chirping during global destruction. * Class::MOP - some more bootstrapping is now done on the new classes * Class::MOP::Class::Immutable *** API CHANGE *** - constructor generation is now handled by the Class::MOP::Method::Constructor class * Class::MOP::Method::Constructor - created this to handle constructor generation in Class::MOP::Class::Immutable * Class::MOP::Attribute *** API CHANGE *** - attributes now delegate to the Class::MOP::Method::Accessor to generate accessors * Class::MOP::Method::Accessor - all accessor generation functions from Class::MOP::Attribute have been moved here 0.35 Sat. Sept. 30, 2006 * scripts/class_browser.pl - initial prototype of a class browser, more on this to come. Comments and patches are very much welcome. * Class::MOP - All Class::MOP::* accessors are no longer re-generated in the bootstrap, instead they are aliased from the originals - fixed tests to reflect - added Class::MOP::Method (and its subclasses) to the bootstrap - adjusted tests for this - added the Class::MOP::Instance attributes to the bootstrap * Class::MOP::Method *** API CHANGE *** - methods are no longer blessed CODE refs but are actual objects which can be CODE-ified - adjusted tests to compensate - adjusted docs for this * Class::MOP::Class - changed how methods are dealt with to encapsulate most of the work into the &get_method_map method - made several adjustments for the change in Class::MOP::Method - &add_attribute now checks if you are adding a duplicate name, and properly removes the old one before installing the new one - added tests for this - adjusted docs for this * Class::MOP::Class::Immutable - added caching of &get_method_map - fixed issue with &get_package_symbol - cleaned up the methods that die (patch by David Wheeler) * Class::MOP::Package - added filtering capabilities to &list_all_package_symbols 0.34 Sat. Aug. 26, 2006 * Class::MOP::Class - added the %:methods attribute, which like the $:version and such just actually goes to the symbol table to get it's stuff. However, it makes the MOP more complete. ** API CHANGE ** - The &create method now requires that all but the package name now is passed in as named parameters. See docs for more info. - updated docs and tests for this * Class::MOP::Object - added &dump method to easily Data::Dumper an object * Class::MOP - cleaned up the initialization of attributes which do not store things in the instance - added the %:methods attribute definition to the bootstrap ~ lots of misc. test cleanup 0.33 Sat. Aug. 19, 2006 * Class::MOP::Class - moved the metaclass cache out of here and it is now in Class::MOP itself. * Class::MOP - moved all the metaclass cache stuff here - fixed all tests for this * Class::MOP::Attribute - reference values (other than CODE refs) are no longer allowed for defaults - added tests for this * Class::MOP::Package - fixed an issue with perl 5.8.1 and how it deals with symbol tables. The namespace hash is now always reloaded from the symbol table. ~ lots of misc. documentation cleanup 0.32 Sat. Aug. 12, 2006 + added Class::MOP::Object so that the metamodel is more complete (and closer to what Perl 6 will probably be). * Class::MOP::Package - refactored entire class, this is now the primary gateway between the metaclass and the Perl 5 symbol table - added many tests for this - this class is now a subclass of Class::MOP::Object - added some tests to reflect this * Class::MOP::Class - refactored all symbol table access to use Class::MOP::Package methods instead * Class::MOP::Module - adding the $:version attribute in the bootstrap so that Module has a version as an attribute - see comment in Class::MOP for details - added the $:authority attribute to this module as well as an &identifier method, to bring us ever closer to Perl 6 goodness - I have added $AUTHORITY to all the modules - added tests for this * Class::MOP::Instance - added &deinitialize_slot for removing slots from an instance - added tests for this * Class::MOP::Attribute - added support for &deinitialize_slot for removing slots from an instance - added tests for this 0.31 Sat. July 15, 2006 * Class::MOP::Class - added &find_method_by_name to locate a method anywhere within the class hierarchy * Class::MOP::Attribute - added &set_value and &get_value for getting the value of the attribute for a particular instance. 0.30 Wed. July 5, 2006 --------------------------------------- This is the first version of Class::MOP to introduce the immutable features which will be used for optimizating the MOP. This support should still be considered experimental, but moving towards stability. --------------------------------------- * Created Class::MOP::Class::Immutable * Created the Class::MOP::Package and Class::MOP::Module classes to more closely conform to Perl 6's meta-model * Class::MOP::Class - now inherits from Class::MOP::Module - several methods moved to ::Module and ::Package and now inherited - added tests for this * Class::MOP::Instance - added an is_inlinable method to allow other classes to check before they attempt to optimize. - added an inline_create_instance to inline instance creation (of course) ** API CHANGE ** - the Class::MOP::Class::*_package_variable methods are all now methods of Class::MOP::Package and called *_package_symbol instead. This is because they are now more general purpose symbol table manipulation methods. 0.29_02 Thurs. June 22, 2006 ++ DEVELOPER RELEASE ++ * Class::MOP::Class - small change in &create so that it behaves properly when inherited - small fix to &clone_instance 0.29_01 Fri. May 12, 2006 ++ DEVELOPER RELEASE ++ - This release works in combination with Moose 0.09_01, it is a developer release because it introduces a new instance sub-protocol and has not yet been optimized. * Class::MOP::Class - anon-classes are now properly garbage collected - added tests for this - improved method modifier wrapping * Class::MOP::Instance - added new instance protocol - added tests for this - changed all relevant modules and examples - Class::MOP::Class - Class::MOP::Attribute - examples/* * metaclass - you no longer need to specify the metaclass itself, if it is not there, Class::MOP::Class is just assumed - updated tests for this * examples/ - added ArrayBasedStorage example to show instance storage using ARRAY refs instead of HASH refs. - added tests for this - InsideOutClass is totally revised using the new instance protocol - added more tests for this 0.26 Mon. April 24, 2006 * Class::MOP::Class - added find_attribute_by_name method - added tests and docs for this - some small optimizations * Class::MOP::Attribute - some small optimizations 0.25 Thurs. April 20, 2006 * Class::MOP::Class - added create_anon_class for creating anonymous classes - added tests for this - added get_all_metaclasses, get_all_metaclass_names and get_all_metaclass_instances method to allow access to all the cached metaclass objects. - attribute slot initialization is now the responsibility of the attribute itself, and construct_instance now delegates appropriately * Class::MOP::Attribute - attribute slot initialization is now the responsibility of the attribute itself, so we added a method for it called initialize_instance_slot * examples/ - adjusted all the examples to use the new attribute initialize_instance_slot method 0.24 Tues. April 11, 2006 * Class::MOP::Class - cleaned up how the before/after/around method modifiers get named with Sub::Name 0.23 Thurs. March 30, 2006 * Class::MOP::Class - fixed the way attribute defaults are handled during instance construction (bug found by chansen) * Class::MOP::Attribute - read-only accessors ('reader') will now die if passed more than one argument (attempting to write to them basically) - added tests for this - adjusted all /example files to comply 0.22 Mon. March 20, 2006 * Class::MOP::Class - localized $@ in the *_package_variable functions because otherwise, it does ugly things in Moose. - added test case for this 0.21 Wed. March 15, 2006 * Class::MOP::Class - fixed issue where metaclasses are reaped from our cache in global destruction, and so are not available in DESTORY calls 0.20 Thurs. March 2, 2006 - removed the dependency for Clone since we no longer to deep-cloning by default. * Class::MOP::Method - added &package_name, &name and &fully_qualified_name methods, some of which were formerly private subs in Class::MOP::Class * Class::MOP::Method::Wrapped - allows for a method to be wrapped with before, after and around modifiers - added tests and docs for this feature * Class::MOP::Class - improved &get_package_symbol - &version and &superclasses now use it - methods are now blessed into Class::MOP::Method whenever possible - added methods to install CLOS-style method modifiers - &add_before_method_modifier - &add_after_method_modifier - &add_around_method_modifier - added tests and docs for these - added &find_next_method_by_name which finds the equivalent of SUPER::method_name 0.12 Thurs. Feb 23, 2006 - reduced the dependency on B, no need to always have the latest * examples/ - added docs to the C3 method dispatch order test - fixed missing Algorithm::C3 dependency by making the test skip if it is not installed 0.11 Mon Feb. 20, 2006 * examples/ - added example of changing method dispatch order to C3 * Class::MOP::Class - changed how clone_instance behaves, it now only does a shallow clone (see docs for more details) - added docs and tests 0.10 Tues Feb. 14, 2006 ** This release was mostly about writing more tests and cleaning out old and dusty code, the MOP should now be considered "ready to use". - adding more tests to get coverage up a little higher, mostly testing errors and edge cases. - test coverage is now at 99% * Class::MOP - no longer optionally exports to UNIVERSAL::meta or creates a custom metaclass generator, use the metaclass pragma instead. * Class::MOP::Class - fixed a number of minor issues which came up in the error/edge-case tests * Class::MOP::Attribute - fixed a number of minor issues which came up in the error/edge-case tests * examples/ - fixing the AttributesWithHistory example, it was broken. 0.06 Thurs Feb. 9, 2006 * metaclass - adding new metaclass pragma to make setting up the metaclass a little more straightforward * Class::MOP - clean up bootstrapping to include more complete attribute definitions for Class::MOP::Class and Class::MOP::Attribute (accessors, readers, writers, etc.) ... it is redundant, but is useful meta-info to have around. * Class::MOP::Class - fixing minor meta-circularity issue with &meta, it is now more useful for subclasses - added &get_attribute_map as an accessor for the hash of attribute meta objects - &compute_all_applicable_attributes now just returns the attribute meta-object, rather than the HASH ref since all the same info can be gotten from the attribute meta-object itself - updated docs & tests to reflect - added &clone_instance method which does a deep clone of the instance structure created by &construct_instance - added docs & tests for this - added Clone as a dependency - added &new_object and &clone_object convience methods to return blessed new or cloned instances - they handle Class::MOP::Class singletons correctly too - added docs & tests for this - cleaned up the &constuct_class_instance so that it behaves more like &construct_instance (and managed the singletons too) - added the &check_metaclass_compatibility method to make sure that metaclasses are upward and downward compatible. - added tests and docs for this * examples/ - adjusting code to use the &Class::MOP::Class::meta fix detailed above - adjusting code to use the metaclass pragma 0.05 Sat Feb. 4, 2006 * Class::MOP::Class - added the &attribute_metaclass and &method_metaclass attributes which contain a metaclass name to use for attributes/methods respectively * Class::MOP - bootstrap additional attributes for Class::MOP::Class * examples/ - adjusted the example code and tests to use the new &attribute_metaclass feature of Class::MOP::Class - added new example: - LazyClass 0.04 Fri Feb. 3, 2006 * Class::MOP::Class - some documentation suggestions from #perl6 * Class::MOP::Attribute - improved error messages * examples/ - added new examples: - AttributesWithHistory - ClassEncapsultedAttributes 0.03 Fri Feb. 3, 2006 - converted to Module::Build instead of EU::MM * Class::MOP::Attribute - refactored method generation code - attributes are now associated with class directly * examples/ - refactored the InsideOut example to take advantage of the Class::MOP::Attribute refactoring - changed example files to .pod files and hide thier package names from PAUSE (I don't want to own these namespaces really, they are just examples) 0.02 Thurs Feb. 2, 2006 - moving examples from t/lib/* to examples/* - adding POD documentation to the examples 0.01 Thurs Feb. 2, 2006 - Initial release CheckDelta.pm100644000767000024 61112200352344 15410 0ustar00etherstaff000000000000Moose-2.1005/incpackage inc::CheckDelta; use Moose; use Path::Class; with 'Dist::Zilla::Role::AfterBuild'; sub after_build { my $self = shift; return unless $ENV{DZIL_RELEASING}; my ($delta) = grep { $_->name eq 'lib/Moose/Manual/Delta.pod' } @{ $self->zilla->files }; die "Moose::Manual::Delta still contains \$NEXT" if $delta->content =~ /\$NEXT/; } 1; Moose000755000767000024 012200352344 14024 5ustar00etherstaff000000000000Moose-2.1005/libRole.pm100644000767000024 2130012200352344 15437 0ustar00etherstaff000000000000Moose-2.1005/lib/Moosepackage Moose::Role; BEGIN { $Moose::Role::AUTHORITY = 'cpan:STEVAN'; } { $Moose::Role::VERSION = '2.1005'; } use strict; use warnings; use Scalar::Util 'blessed'; use Carp 'croak'; use Class::Load 'is_class_loaded'; use Sub::Exporter; use Moose (); use Moose::Util (); use Moose::Exporter; use Moose::Meta::Role; use Moose::Util::TypeConstraints; sub extends { croak "Roles do not support 'extends' (you can use 'with' to specialize a role)"; } sub with { Moose::Util::apply_all_roles( shift, @_ ); } sub requires { my $meta = shift; croak "Must specify at least one method" unless @_; $meta->add_required_methods(@_); } sub excludes { my $meta = shift; croak "Must specify at least one role" unless @_; $meta->add_excluded_roles(@_); } sub has { my $meta = shift; my $name = shift; croak 'Usage: has \'name\' => ( key => value, ... )' if @_ == 1; my %context = Moose::Util::_caller_info; $context{context} = 'has declaration'; $context{type} = 'role'; my %options = ( definition_context => \%context, @_ ); my $attrs = ( ref($name) eq 'ARRAY' ) ? $name : [ ($name) ]; $meta->add_attribute( $_, %options ) for @$attrs; } sub _add_method_modifier { my $type = shift; my $meta = shift; if ( ref($_[0]) eq 'Regexp' ) { croak "Roles do not currently support regex " . " references for $type method modifiers"; } Moose::Util::add_method_modifier($meta, $type, \@_); } sub before { _add_method_modifier('before', @_) } sub after { _add_method_modifier('after', @_) } sub around { _add_method_modifier('around', @_) } # see Moose.pm for discussion sub super { return unless $Moose::SUPER_BODY; $Moose::SUPER_BODY->(@Moose::SUPER_ARGS); } sub override { my $meta = shift; my ( $name, $code ) = @_; $meta->add_override_method_modifier( $name, $code ); } sub inner { croak "Roles cannot support 'inner'"; } sub augment { croak "Roles cannot support 'augment'"; } Moose::Exporter->setup_import_methods( with_meta => [ qw( with requires excludes has before after around override ) ], as_is => [ qw( extends super inner augment ), \&Carp::confess, \&Scalar::Util::blessed, ], ); sub init_meta { shift; my %args = @_; my $role = $args{for_class}; unless ($role) { require Moose; Moose->throw_error("Cannot call init_meta without specifying a for_class"); } my $metaclass = $args{metaclass} || "Moose::Meta::Role"; my $meta_name = exists $args{meta_name} ? $args{meta_name} : 'meta'; Moose->throw_error("The Metaclass $metaclass must be loaded. (Perhaps you forgot to 'use $metaclass'?)") unless is_class_loaded($metaclass); Moose->throw_error("The Metaclass $metaclass must be a subclass of Moose::Meta::Role.") unless $metaclass->isa('Moose::Meta::Role'); # make a subtype for each Moose role role_type $role unless find_type_constraint($role); my $meta; if ( $meta = Class::MOP::get_metaclass_by_name($role) ) { unless ( $meta->isa("Moose::Meta::Role") ) { my $error_message = "$role already has a metaclass, but it does not inherit $metaclass ($meta)."; if ( $meta->isa('Moose::Meta::Class') ) { Moose->throw_error($error_message . ' You cannot make the same thing a role and a class. Remove either Moose or Moose::Role.'); } else { Moose->throw_error($error_message); } } } else { $meta = $metaclass->initialize($role); } if (defined $meta_name) { # also check for inherited non moose 'meta' method? my $existing = $meta->get_method($meta_name); if ($existing && !$existing->isa('Class::MOP::Method::Meta')) { Carp::cluck "Moose::Role is overwriting an existing method named " . "$meta_name in role $role with a method " . "which returns the class's metaclass. If this is " . "actually what you want, you should remove the " . "existing method, otherwise, you should rename or " . "disable this generated method using the " . "'-meta_name' option to 'use Moose::Role'."; } $meta->_add_meta_method($meta_name); } return $meta; } 1; # ABSTRACT: The Moose Role __END__ =pod =head1 NAME Moose::Role - The Moose Role =head1 VERSION version 2.1005 =head1 SYNOPSIS package Eq; use Moose::Role; # automatically turns on strict and warnings requires 'equal'; sub no_equal { my ($self, $other) = @_; !$self->equal($other); } # ... then in your classes package Currency; use Moose; # automatically turns on strict and warnings with 'Eq'; sub equal { my ($self, $other) = @_; $self->as_float == $other->as_float; } # ... and also package Comparator; use Moose; has compare_to => ( is => 'ro', does => 'Eq', handles => 'Eq', ); # ... which allows my $currency1 = Currency->new(...); my $currency2 = Currency->new(...); Comparator->new(compare_to => $currency1)->equal($currency2); =head1 DESCRIPTION The concept of roles is documented in L. This document serves as API documentation. =head1 EXPORTED FUNCTIONS Moose::Role currently supports all of the functions that L exports, but differs slightly in how some items are handled (see L below for details). Moose::Role also offers two role-specific keyword exports: =over 4 =item B Roles can require that certain methods are implemented by any class which C the role. Note that attribute accessors also count as methods for the purposes of satisfying the requirements of a role. =item B Roles can C other roles, in effect saying "I can never be combined with these C<@role_names>". This is a feature which should not be used lightly. =back =head2 B Moose::Role offers a way to remove the keywords it exports, through the C method. You simply have to say C at the bottom of your code for this to work. =head1 METACLASS When you use Moose::Role, you can specify traits which will be applied to your role metaclass: use Moose::Role -traits => 'My::Trait'; This is very similar to the attribute traits feature. When you do this, your class's C object will have the specified traits applied to it. See L for more details. =head1 APPLYING ROLES In addition to being applied to a class using the 'with' syntax (see L) and using the L 'apply_all_roles' method, roles may also be applied to an instance of a class using L 'apply_all_roles' or the role's metaclass: MyApp::Test::SomeRole->meta->apply( $instance ); Doing this creates a new, mutable, anonymous subclass, applies the role to that, and reblesses. In a debugger, for example, you will see class names of the form C< Moose::Meta::Class::__ANON__::SERIAL::6 >, which means that doing a 'ref' on your instance may not return what you expect. See L for 'DOES'. Additional params may be added to the new instance by providing 'rebless_params'. See L. =head1 CAVEATS Role support has only a few caveats: =over 4 =item * Roles cannot use the C keyword; it will throw an exception for now. The same is true of the C and C keywords (not sure those really make sense for roles). All other Moose keywords will be I so that they can be applied to the consuming class. =item * Role composition does its best to B be order-sensitive when it comes to conflict resolution and requirements detection. However, it is order-sensitive when it comes to method modifiers. All before/around/after modifiers are included whenever a role is composed into a class, and then applied in the order in which the roles are used. This also means that there is no conflict for before/around/after modifiers. In most cases, this will be a non-issue; however, it is something to keep in mind when using method modifiers in a role. You should never assume any ordering. =back =head1 BUGS See L for details on reporting bugs. =head1 AUTHOR Moose is maintained by the Moose Cabal, along with the help of many contributors. See L and L for details. =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2013 by Infinity Interactive, Inc.. This is free software; you can redistribute it and/or modify it under the same terms as the Perl 5 programming language system itself. =cut Util.pm100644000767000024 4331312200352344 15463 0ustar00etherstaff000000000000Moose-2.1005/lib/Moosepackage Moose::Util; BEGIN { $Moose::Util::AUTHORITY = 'cpan:STEVAN'; } { $Moose::Util::VERSION = '2.1005'; } use strict; use warnings; use Class::Load 0.07 qw(load_class load_first_existing_class); use Data::OptList; use Params::Util qw( _STRING ); use Sub::Exporter; use Scalar::Util 'blessed'; use List::Util qw(first); use List::MoreUtils qw(any all); use overload (); use Try::Tiny; use Class::MOP; my @exports = qw[ find_meta does_role search_class_by_role ensure_all_roles apply_all_roles with_traits get_all_init_args get_all_attribute_values resolve_metatrait_alias resolve_metaclass_alias add_method_modifier english_list meta_attribute_alias meta_class_alias ]; Sub::Exporter::setup_exporter({ exports => \@exports, groups => { all => \@exports } }); ## some utils for the utils ... sub find_meta { Class::MOP::class_of(@_) } ## the functions ... sub does_role { my ($class_or_obj, $role) = @_; if (try { $class_or_obj->isa('Moose::Object') }) { return $class_or_obj->does($role); } my $meta = find_meta($class_or_obj); return unless defined $meta; return unless $meta->can('does_role'); return 1 if $meta->does_role($role); return; } sub search_class_by_role { my ($class_or_obj, $role) = @_; my $meta = find_meta($class_or_obj); return unless defined $meta; my $role_name = blessed $role ? $role->name : $role; foreach my $class ($meta->class_precedence_list) { my $_meta = find_meta($class); next unless defined $_meta; foreach my $role (@{ $_meta->roles || [] }) { return $class if $role->name eq $role_name; } } return; } # this can possibly behave in unexpected ways because the roles being composed # before being applied could differ from call to call; I'm not sure if or how # to document this possible quirk. sub ensure_all_roles { my $applicant = shift; _apply_all_roles($applicant, sub { !does_role($applicant, $_) }, @_); } sub apply_all_roles { my $applicant = shift; _apply_all_roles($applicant, undef, @_); } sub _apply_all_roles { my $applicant = shift; my $role_filter = shift; unless (@_) { require Moose; Moose->throw_error("Must specify at least one role to apply to $applicant"); } # If @_ contains role meta objects, mkopt will think that they're values, # because they're references. In other words (roleobj1, roleobj2, # roleobj3) will become [ [ roleobj1, roleobj2 ], [ roleobj3, undef ] ] # -- this is no good. We'll preprocess @_ first to eliminate the potential # bug. # -- rjbs, 2011-04-08 my $roles = Data::OptList::mkopt( [@_], { moniker => 'role', name_test => sub { ! ref $_[0] or blessed($_[0]) && $_[0]->isa('Moose::Meta::Role') } }); my @role_metas; foreach my $role (@$roles) { my $meta; if ( blessed $role->[0] ) { $meta = $role->[0]; } else { load_class( $role->[0] , $role->[1] ); $meta = find_meta( $role->[0] ); } unless ($meta && $meta->isa('Moose::Meta::Role') ) { require Moose; Moose->throw_error( "You can only consume roles, " . $role->[0] . " is not a Moose role" ); } push @role_metas, [ $meta, $role->[1] ]; } if ( defined $role_filter ) { @role_metas = grep { local $_ = $_->[0]; $role_filter->() } @role_metas; } return unless @role_metas; load_class($applicant) unless blessed($applicant) || Class::MOP::class_of($applicant); my $meta = ( blessed $applicant ? $applicant : Moose::Meta::Class->initialize($applicant) ); if ( scalar @role_metas == 1 ) { my ( $role, $params ) = @{ $role_metas[0] }; $role->apply( $meta, ( defined $params ? %$params : () ) ); } else { Moose::Meta::Role->combine(@role_metas)->apply($meta); } } sub with_traits { my ($class, @roles) = @_; return $class unless @roles; return Moose::Meta::Class->create_anon_class( superclasses => [$class], roles => \@roles, cache => 1, )->name; } # instance deconstruction ... sub get_all_attribute_values { my ($class, $instance) = @_; return +{ map { $_->name => $_->get_value($instance) } grep { $_->has_value($instance) } $class->get_all_attributes }; } sub get_all_init_args { my ($class, $instance) = @_; return +{ map { $_->init_arg => $_->get_value($instance) } grep { $_->has_value($instance) } grep { defined($_->init_arg) } $class->get_all_attributes }; } sub resolve_metatrait_alias { return resolve_metaclass_alias( @_, trait => 1 ); } sub _build_alias_package_name { my ($type, $name, $trait) = @_; return 'Moose::Meta::' . $type . '::Custom::' . ( $trait ? 'Trait::' : '' ) . $name; } { my %cache; sub resolve_metaclass_alias { my ( $type, $metaclass_name, %options ) = @_; my $cache_key = $type . q{ } . ( $options{trait} ? '-Trait' : '' ); return $cache{$cache_key}{$metaclass_name} if $cache{$cache_key}{$metaclass_name}; my $possible_full_name = _build_alias_package_name( $type, $metaclass_name, $options{trait} ); my $loaded_class = load_first_existing_class( $possible_full_name, $metaclass_name ); return $cache{$cache_key}{$metaclass_name} = $loaded_class->can('register_implementation') ? $loaded_class->register_implementation : $loaded_class; } } sub add_method_modifier { my ( $class_or_obj, $modifier_name, $args ) = @_; my $meta = $class_or_obj->can('add_before_method_modifier') ? $class_or_obj : find_meta($class_or_obj); my $code = pop @{$args}; my $add_modifier_method = 'add_' . $modifier_name . '_method_modifier'; if ( my $method_modifier_type = ref( @{$args}[0] ) ) { if ( $method_modifier_type eq 'Regexp' ) { my @all_methods = $meta->get_all_methods; my @matched_methods = grep { $_->name =~ @{$args}[0] } @all_methods; $meta->$add_modifier_method( $_->name, $code ) for @matched_methods; } elsif ($method_modifier_type eq 'ARRAY') { $meta->$add_modifier_method( $_, $code ) for @{$args->[0]}; } else { $meta->throw_error( sprintf( "Methods passed to %s must be provided as a list, arrayref or regex, not %s", $modifier_name, $method_modifier_type, ) ); } } else { $meta->$add_modifier_method( $_, $code ) for @{$args}; } } sub english_list { my @items = sort @_; return $items[0] if @items == 1; return "$items[0] and $items[1]" if @items == 2; my $tail = pop @items; my $list = join ', ', @items; $list .= ', and ' . $tail; return $list; } sub _caller_info { my $level = @_ ? ($_[0] + 1) : 2; my %info; @info{qw(package file line)} = caller($level); return %info; } sub _create_alias { my ($type, $name, $trait, $for) = @_; my $package = _build_alias_package_name($type, $name, $trait); Class::MOP::Class->initialize($package)->add_method( register_implementation => sub { $for } ); } sub meta_attribute_alias { my ($to, $from) = @_; $from ||= caller; my $meta = Class::MOP::class_of($from); my $trait = $meta->isa('Moose::Meta::Role'); _create_alias('Attribute', $to, $trait, $from); } sub meta_class_alias { my ($to, $from) = @_; $from ||= caller; my $meta = Class::MOP::class_of($from); my $trait = $meta->isa('Moose::Meta::Role'); _create_alias('Class', $to, $trait, $from); } # XXX - this should be added to Params::Util sub _STRINGLIKE0 ($) { return 1 if _STRING( $_[0] ); if ( blessed $_[0] ) { return overload::Method( $_[0], q{""} ); } return 1 if defined $_[0] && $_[0] eq q{}; return 0; } sub _reconcile_roles_for_metaclass { my ($class_meta_name, $super_meta_name) = @_; my @role_differences = _role_differences( $class_meta_name, $super_meta_name, ); # handle the case where we need to fix compatibility between a class and # its parent, but all roles in the class are already also done by the # parent # see t/metaclasses/metaclass_compat_no_fixing_bug.t return $super_meta_name unless @role_differences; return Moose::Meta::Class->create_anon_class( superclasses => [$super_meta_name], roles => [map { $_->name } @role_differences], cache => 1, )->name; } sub _role_differences { my ($class_meta_name, $super_meta_name) = @_; my @super_role_metas = map { $_->isa('Moose::Meta::Role::Composite') ? (@{ $_->get_roles }) : ($_) } $super_meta_name->meta->can('_roles_with_inheritance') ? $super_meta_name->meta->_roles_with_inheritance : $super_meta_name->meta->can('roles') ? @{ $super_meta_name->meta->roles } : (); my @role_metas = map { $_->isa('Moose::Meta::Role::Composite') ? (@{ $_->get_roles }) : ($_) } $class_meta_name->meta->can('_roles_with_inheritance') ? $class_meta_name->meta->_roles_with_inheritance : $class_meta_name->meta->can('roles') ? @{ $class_meta_name->meta->roles } : (); my @differences; for my $role_meta (@role_metas) { push @differences, $role_meta unless any { $_->name eq $role_meta->name } @super_role_metas; } return @differences; } sub _classes_differ_by_roles_only { my ( $self_meta_name, $super_meta_name ) = @_; my $common_base_name = _find_common_base( $self_meta_name, $super_meta_name ); return unless defined $common_base_name; my @super_meta_name_ancestor_names = _get_ancestors_until( $super_meta_name, $common_base_name ); my @class_meta_name_ancestor_names = _get_ancestors_until( $self_meta_name, $common_base_name ); return unless all { _is_role_only_subclass($_) } @super_meta_name_ancestor_names, @class_meta_name_ancestor_names; return 1; } sub _find_common_base { my ($meta1, $meta2) = map { Class::MOP::class_of($_) } @_; return unless defined $meta1 && defined $meta2; # FIXME? This doesn't account for multiple inheritance (not sure # if it needs to though). For example, if somewhere in $meta1's # history it inherits from both ClassA and ClassB, and $meta2 # inherits from ClassB & ClassA, does it matter? And what crazy # fool would do that anyway? my %meta1_parents = map { $_ => 1 } $meta1->linearized_isa; return first { $meta1_parents{$_} } $meta2->linearized_isa; } sub _get_ancestors_until { my ($start_name, $until_name) = @_; my @ancestor_names; for my $ancestor_name (Class::MOP::class_of($start_name)->linearized_isa) { last if $ancestor_name eq $until_name; push @ancestor_names, $ancestor_name; } return @ancestor_names; } sub _is_role_only_subclass { my ($meta_name) = @_; my $meta = Class::MOP::Class->initialize($meta_name); my @parent_names = $meta->superclasses; # XXX: don't feel like messing with multiple inheritance here... what would # that even do? return unless @parent_names == 1; my ($parent_name) = @parent_names; my $parent_meta = Class::MOP::Class->initialize($parent_name); # only get the roles attached to this particular class, don't look at # superclasses my @roles = $meta->can('calculate_all_roles') ? $meta->calculate_all_roles : (); # it's obviously not a role-only subclass if it doesn't do any roles return unless @roles; # loop over all methods that are a part of the current class # (not inherited) for my $method ( $meta->_get_local_methods ) { # always ignore meta next if $method->isa('Class::MOP::Method::Meta'); # we'll deal with attributes below next if $method->can('associated_attribute'); # if the method comes from a role we consumed, ignore it next if $meta->can('does_role') && $meta->does_role($method->original_package_name); # FIXME - this really isn't right. Just because a modifier is # defined in a role doesn't mean it isn't _also_ defined in the # subclass. next if $method->isa('Class::MOP::Method::Wrapped') && ( (!scalar($method->around_modifiers) || any { $_->has_around_method_modifiers($method->name) } @roles) && (!scalar($method->before_modifiers) || any { $_->has_before_method_modifiers($method->name) } @roles) && (!scalar($method->after_modifiers) || any { $_->has_after_method_modifiers($method->name) } @roles) ); return 0; } # loop over all attributes that are a part of the current class # (not inherited) # FIXME - this really isn't right. Just because an attribute is # defined in a role doesn't mean it isn't _also_ defined in the # subclass. for my $attr (map { $meta->get_attribute($_) } $meta->get_attribute_list) { next if any { $_->has_attribute($attr->name) } @roles; return 0; } return 1; } 1; # ABSTRACT: Utilities for working with Moose classes __END__ =pod =head1 NAME Moose::Util - Utilities for working with Moose classes =head1 VERSION version 2.1005 =head1 SYNOPSIS use Moose::Util qw/find_meta does_role search_class_by_role/; my $meta = find_meta($object) || die "No metaclass found"; if (does_role($object, $role)) { print "The object can do $role!\n"; } my $class = search_class_by_role($object, 'FooRole'); print "Nearest class with 'FooRole' is $class\n"; =head1 DESCRIPTION This module provides a set of utility functions. Many of these functions are intended for use in Moose itself or MooseX modules, but some of them may be useful for use in your own code. =head1 EXPORTED FUNCTIONS =over 4 =item B This method takes a class name or object and attempts to find a metaclass for the class, if one exists. It will B create one if it does not yet exist. =item B Returns true if C<$class_or_obj> does the given C<$role_or_obj>. The role can be provided as a name or a L object. The class must already have a metaclass for this to work. If it doesn't, this function simply returns false. =item B Returns the first class in the class's precedence list that does C<$role_or_obj>, if any. The role can be either a name or a L object. The class must already have a metaclass for this to work. =item B This function applies one or more roles to the given C<$applicant> The applicant can be a role name, class name, or object. The C<$applicant> must already have a metaclass object. The list of C<@roles> should a list of names or L objects, each of which can be followed by an optional hash reference of options (C<-excludes> and C<-alias>). =item B This function is similar to C, but only applies roles that C<$applicant> does not already consume. =item B This function creates a new class from C<$class_name> with each of C<@role_names> applied. It returns the name of the new class. =item B Returns a hash reference containing all of the C<$instance>'s attributes. The keys are attribute names. =item B Returns a hash reference containing all of the C values for the instance's attributes. The values are the associated attribute values. If an attribute does not have a defined C, it is skipped. This could be useful in cloning an object. =item B =item B Resolves a short name to a full class name. Short names are often used when specifying the C or C option for an attribute: has foo => ( metaclass => "Bar", ); The name resolution mechanism is covered in L. =item B =item B Create an alias from the class C<$from> (or the current package, if C<$from> is unspecified), so that L works properly. =item B Given a list of scalars, turns them into a proper list in English ("one and two", "one, two, three, and four"). This is used to help us make nicer error messages. =back =head1 TODO Here is a list of possible functions to write =over 4 =item discovering original method from modified method =item search for origin class of a method or attribute =back =head1 BUGS See L for details on reporting bugs. =head1 AUTHOR Moose is maintained by the Moose Cabal, along with the help of many contributors. See L and L for details. =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2013 by Infinity Interactive, Inc.. This is free software; you can redistribute it and/or modify it under the same terms as the Perl 5 programming language system itself. =cut Test000755000767000024 012200352344 13661 5ustar00etherstaff000000000000Moose-2.1005/libMoose.pm100644000767000024 1002512200352344 15457 0ustar00etherstaff000000000000Moose-2.1005/lib/Testpackage Test::Moose; BEGIN { $Test::Moose::AUTHORITY = 'cpan:STEVAN'; } { $Test::Moose::VERSION = '2.1005'; } use strict; use warnings; use Sub::Exporter; use Test::Builder; use List::MoreUtils 'all'; use Moose::Util 'does_role', 'find_meta'; my @exports = qw[ meta_ok does_ok has_attribute_ok with_immutable ]; Sub::Exporter::setup_exporter({ exports => \@exports, groups => { default => \@exports } }); ## the test builder instance ... my $Test = Test::Builder->new; ## exported functions sub meta_ok ($;$) { my ($class_or_obj, $message) = @_; $message ||= "The object has a meta"; if (find_meta($class_or_obj)) { return $Test->ok(1, $message) } else { return $Test->ok(0, $message); } } sub does_ok ($$;$) { my ($class_or_obj, $does, $message) = @_; $message ||= "The object does $does"; if (does_role($class_or_obj, $does)) { return $Test->ok(1, $message) } else { return $Test->ok(0, $message); } } sub has_attribute_ok ($$;$) { my ($class_or_obj, $attr_name, $message) = @_; $message ||= "The object does has an attribute named $attr_name"; my $meta = find_meta($class_or_obj); if ($meta->find_attribute_by_name($attr_name)) { return $Test->ok(1, $message) } else { return $Test->ok(0, $message); } } sub with_immutable (&@) { my $block = shift; my $before = $Test->current_test; my $passing_before = (Test::Builder->VERSION < 1.005 ? 0 : $Test->history->pass_count) || 0; $block->(0); Class::MOP::class_of($_)->make_immutable for @_; $block->(1); my $num_tests = $Test->current_test - $before; my $all_passed = Test::Builder->VERSION < 1.005 ? all { $_ } ($Test->summary)[-$num_tests..-1] : $num_tests == $Test->history->pass_count - $passing_before; return $all_passed; } 1; # ABSTRACT: Test functions for Moose specific features __END__ =pod =head1 NAME Test::Moose - Test functions for Moose specific features =head1 VERSION version 2.1005 =head1 SYNOPSIS use Test::More plan => 1; use Test::Moose; meta_ok($class_or_obj, "... Foo has a ->meta"); does_ok($class_or_obj, $role, "... Foo does the Baz role"); has_attribute_ok($class_or_obj, $attr_name, "... Foo has the 'bar' attribute"); =head1 DESCRIPTION This module provides some useful test functions for Moose based classes. It is an experimental first release, so comments and suggestions are very welcome. =head1 EXPORTED FUNCTIONS =over 4 =item B Tests if a class or object has a metaclass. =item B Tests if a class or object does a certain role, similar to what C does for the C method. =item B Tests if a class or object has a certain attribute, similar to what C does for the methods. =item B Runs B (which should contain normal tests) twice, and make each class in C<@class_names> immutable in between the two runs. The B block is called with a single boolean argument indicating whether or not the classes have been made immutable yet. =back =head1 TODO =over 4 =item Convert the Moose test suite to use this module. =item Here is a list of possible functions to write =over 4 =item immutability predicates =item anon-class predicates =item discovering original method from modified method =item attribute metaclass predicates (attribute_isa?) =back =back =head1 SEE ALSO =over 4 =item L =back =head1 BUGS See L for details on reporting bugs. =head1 AUTHOR Moose is maintained by the Moose Cabal, along with the help of many contributors. See L and L for details. =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2013 by Infinity Interactive, Inc.. This is free software; you can redistribute it and/or modify it under the same terms as the Perl 5 programming language system itself. =cut basics000755000767000024 012200352344 13703 5ustar00etherstaff000000000000Moose-2.1005/tcreate.t100644000767000024 234412200352344 15476 0ustar00etherstaff000000000000Moose-2.1005/t/basics#!/usr/bin/perl use strict; use warnings; use Test::More; use Test::Fatal; use Class::Load 'is_class_loaded'; { package Class; use Moose; package Foo; use Moose::Role; sub foo_role_applied { 1 } package Conflicts::With::Foo; use Moose::Role; sub foo_role_applied { 0 } package Not::A::Role; sub lol_wut { 42 } } my $new_class; is( exception { $new_class = Moose::Meta::Class->create( 'Class::WithFoo', superclasses => ['Class'], roles => ['Foo'], ); }, undef, 'creating lives' ); ok $new_class; my $with_foo = Class::WithFoo->new; ok $with_foo->foo_role_applied; isa_ok $with_foo, 'Class', '$with_foo'; like( exception { Moose::Meta::Class->create( 'Made::Of::Fail', superclasses => ['Class'], roles => 'Foo', # "oops" ); }, qr/You must pass an ARRAY ref of roles/ ); ok !is_class_loaded('Made::Of::Fail'), "did not create Made::Of::Fail"; isnt( exception { Moose::Meta::Class->create( 'Continuing::To::Fail', superclasses => ['Class'], roles => ['Foo', 'Conflicts::With::Foo'], ); }, undef, 'conflicting roles == death' ); # XXX: Continuing::To::Fail gets created anyway done_testing; instance.t100644000767000024 707212200352344 15534 0ustar00etherstaff000000000000Moose-2.1005/t/cmopuse strict; use warnings; use Test::More; use Test::Fatal; use Scalar::Util qw/isweak reftype/; use Class::MOP::Instance; can_ok( "Class::MOP::Instance", $_ ) for qw/ new create_instance get_all_slots initialize_all_slots deinitialize_all_slots get_slot_value set_slot_value initialize_slot deinitialize_slot is_slot_initialized weaken_slot_value strengthen_slot_value inline_get_slot_value inline_set_slot_value inline_initialize_slot inline_deinitialize_slot inline_is_slot_initialized inline_weaken_slot_value inline_strengthen_slot_value /; { package Foo; use metaclass; Foo->meta->add_attribute('moosen'); package Bar; use metaclass; use base qw/Foo/; Bar->meta->add_attribute('elken'); } my $mi_foo = Foo->meta->get_meta_instance; isa_ok($mi_foo, "Class::MOP::Instance"); is_deeply( [ $mi_foo->get_all_slots ], [ "moosen" ], '... get all slots for Foo'); my $mi_bar = Bar->meta->get_meta_instance; isa_ok($mi_bar, "Class::MOP::Instance"); isnt($mi_foo, $mi_bar, '... they are not the same instance'); is_deeply( [ sort $mi_bar->get_all_slots ], [ "elken", "moosen" ], '... get all slots for Bar'); my $i_foo = $mi_foo->create_instance; isa_ok($i_foo, "Foo"); { my $i_foo_2 = $mi_foo->create_instance; isa_ok($i_foo_2, "Foo"); isnt($i_foo_2, $i_foo, '... not the same instance'); is_deeply($i_foo, $i_foo_2, '... but the same structure'); } ok(!$mi_foo->is_slot_initialized( $i_foo, "moosen" ), "slot not initialized"); ok(!defined($mi_foo->get_slot_value( $i_foo, "moosen" )), "... no value for slot"); $mi_foo->initialize_slot( $i_foo, "moosen" ); #Removed becayse slot initialization works differently now (groditi) #ok($mi_foo->is_slot_initialized( $i_foo, "moosen" ), "slot initialized"); ok(!defined($mi_foo->get_slot_value( $i_foo, "moosen" )), "... but no value for slot"); $mi_foo->set_slot_value( $i_foo, "moosen", "the value" ); is($mi_foo->get_slot_value( $i_foo, "moosen" ), "the value", "... get slot value"); ok(!$i_foo->can('moosen'), '... Foo cant moosen'); my $ref = []; $mi_foo->set_slot_value( $i_foo, "moosen", $ref ); $mi_foo->weaken_slot_value( $i_foo, "moosen" ); ok( isweak($i_foo->{moosen}), '... white box test of weaken' ); is( $mi_foo->get_slot_value( $i_foo, "moosen" ), $ref, "weak value is fetchable" ); ok( !isweak($mi_foo->get_slot_value( $i_foo, "moosen" )), "return value not weak" ); undef $ref; is( $mi_foo->get_slot_value( $i_foo, "moosen" ), undef, "weak value destroyed" ); $ref = []; $mi_foo->set_slot_value( $i_foo, "moosen", $ref ); undef $ref; is( reftype( $mi_foo->get_slot_value( $i_foo, "moosen" ) ), "ARRAY", "value not weak yet" ); $mi_foo->weaken_slot_value( $i_foo, "moosen" ); is( $mi_foo->get_slot_value( $i_foo, "moosen" ), undef, "weak value destroyed" ); $ref = []; $mi_foo->set_slot_value( $i_foo, "moosen", $ref ); $mi_foo->weaken_slot_value( $i_foo, "moosen" ); ok( isweak($i_foo->{moosen}), '... white box test of weaken' ); $mi_foo->strengthen_slot_value( $i_foo, "moosen" ); ok( !isweak($i_foo->{moosen}), '... white box test of weaken' ); undef $ref; is( reftype( $mi_foo->get_slot_value( $i_foo, "moosen" ) ), "ARRAY", "weak value can be strengthened" ); $mi_foo->deinitialize_slot( $i_foo, "moosen" ); ok(!$mi_foo->is_slot_initialized( $i_foo, "moosen" ), "slot deinitialized"); ok(!defined($mi_foo->get_slot_value( $i_foo, "moosen" )), "... no value for slot"); done_testing; RT_41255.t100644000767000024 202112200352344 15002 0ustar00etherstaff000000000000Moose-2.1005/t/cmopuse strict; use Test::More; use Test::Fatal; use Class::MOP; { package BaseClass; sub m1 { 1 } sub m2 { 2 } sub m3 { 3 } sub m4 { 4 } sub m5 { 5 } package Derived; use base qw(BaseClass); sub m1; sub m2 (); sub m3 :method; sub m4; m4() if 0; sub m5; our $m5;; } my $meta = Class::MOP::Class->initialize('Derived'); my %methods = map { $_ => $meta->find_method_by_name($_) } 'm1' .. 'm5'; while (my ($name, $meta_method) = each %methods) { is $meta_method->fully_qualified_name, "Derived::${name}"; like( exception { $meta_method->execute }, qr/Undefined subroutine .* called at/ ); } { package Derived; eval <<'EOC'; sub m1 { 'affe' } sub m2 () { 'apan' } sub m3 :method { 'tiger' } sub m4 { 'birne' } sub m5 { 'apfel' } EOC } while (my ($name, $meta_method) = each %methods) { is $meta_method->fully_qualified_name, "Derived::${name}"; is( exception { $meta_method->execute }, undef ); } done_testing; MyMooseA.pm100600000767000024 11612200352344 15342 0ustar00etherstaff000000000000Moose-2.1005/t/libpackage MyMooseA; use Moose; has 'b' => (is => 'rw', isa => 'MyMooseB'); 1;MyMooseB.pm100600000767000024 4112200352344 15320 0ustar00etherstaff000000000000Moose-2.1005/t/libpackage MyMooseB; use Moose; 1;methods.t100644000767000024 170012200352344 15551 0ustar00etherstaff000000000000Moose-2.1005/t/rolesuse strict; use warnings; use Test::More; use Moose::Role (); my $test1 = Moose::Meta::Role->create_anon_role; $test1->add_method( 'foo1', sub { } ); ok( $test1->has_method('foo1'), 'anon role has a foo1 method' ); my $t1_am = $test1->get_method('foo1')->associated_metaclass; ok( $t1_am, 'associated_metaclass is defined' ); isa_ok( $t1_am, 'Moose::Meta::Role', 'associated_metaclass is correct class' ); like( $t1_am->name(), qr/::__ANON__::/, 'associated_metaclass->name looks like an anonymous class' ); { package Test2; use Moose::Role; sub foo2 { } } ok( Test2->meta->has_method('foo2'), 'Test2 role has a foo2 method' ); my $t2_am = Test2->meta->get_method('foo2')->associated_metaclass; ok( $t2_am, 'associated_metaclass is defined' ); isa_ok( $t2_am, 'Moose::Meta::Role', 'associated_metaclass is correct class' ); is( $t2_am->name(), 'Test2', 'associated_metaclass->name is Test2' ); done_testing; 00-check-deps.t100644000767000024 26612200352344 15173 0ustar00etherstaff000000000000Moose-2.1005/tuse Test::More 0.94; use Test::CheckDeps 0.004; check_dependencies('classic'); if (0) { BAIL_OUT("Missing dependencies") if !Test::More->builder->is_passing; } done_testing; doc000755000767000024 012200352344 12741 5ustar00etherstaff000000000000Moose-2.1005moosex-compile100600000767000024 2440612200352344 16002 0ustar00etherstaff000000000000Moose-2.1005/docMooseX-Compile, wherein Yuval explains how MooseX::Compile is supposed to work and what needs doing. TODO: PLEASE EDIT ME 19:11 hiya 19:12 hola 19:13 so, my empty mail was an attempted abort 19:13 but was going to be "MX::Compile doesn't depend on MX::Compile::CLI. should it?" 19:13 ah, ok =) 19:13 but i'm without my laptop, so i couldn't actually check my assumption 19:14 no, because MX::Compile::CLI is "just a a frontend" and at the time the dependencies were a little sketchy 19:14 they've since matured, so maybe it should dep 19:21 * obra nods 19:21 I was on a plane and was trying to see if MX::Compile was at the point where I could try trivial tests 19:22 ah 19:22 so the answer is definitely maybe ;-) 19:22 i haven't been able to make time for it in the past week 19:23 if you guys hand me small, targetted test cases (just commit to it) of code that passes under plain Moose and should pass with MX::Compile i can probably do that stuff pretty quickly 19:23 but the biggest barrier MXC has right now is testing, in order for it to progress towards something production worthy it basically needs to pass the Moose test suite 19:23 except without the Moose test suite's assumptions 19:23 about state and module loading, and all that 19:24 and doing that is a much more daunting prospect than hacking on MXC itself 19:24 understood. the problem is that I still don't have a good sense of how to get it going, even manually 19:24 ah 19:24 none of the test files seem to show off what I need 19:24 i can walk you through thjat 19:25 the assumptions of the system are: 19:25 the class you are compiling is in its own .pm using standard moose sugar 19:25 there is one package in that file 19:26 the compiler object takes the metaclass and the .pm file as args 19:26 it serializes the metaclass to a .mopc file, and the generated code into a .pmc 19:26 the .pmc contains the original .pm verbatim 19:26 except that all the moose sugar does nothing 19:27 meta is overriden to lazy load .mopc 19:27 and the class is supposed to be usable without loading Moose at all 19:27 what is the point of containing the original pm verbatim? 19:27 the user code 19:28 could open and slurp and eval 19:28 but this is a little more flexible 19:28 basically any subroutines the user has written, global/lexical variable initialization, loading of assorted modules etc all must work 19:28 are you using the flexibility? 19:28 (open, slurp, eval sounds suspiciously like "do") 19:29 can't use do/require/etc because it will go to the .pmc 19:29 instead of the .pm 19:29 the flexibility is helpful because you get a lexical set if the code is compiled 19:29 for when you need to do trickery 19:29 see Moose/Object.pm 19:29 I didn't think 'do' had that logic. but ok :) 19:30 anyway 19:30 do go on 19:30 now that we have Devel::Declare that might prove even simpler 19:30 simply replacing has() etc to export the subs inline 19:30 and write the resulting buffers to a .pmc 19:30 but that's for Later™ 19:30 The fact that the TM shows up in my terminal scare me 19:30 but only a bit less than that you typed it ;) 19:30 utf8++ 19:31 ubuntu++ 19:31 most linuxes seem to get that refreshingly right 19:31 so, erm 19:31 yeah. it's pleasant. 19:31 mxcompile 19:31 anyway 19:31 that is a nice frontend to the compiler object 19:31 I guess "what do I need to do to try MX::Compile for prophet+sd?" 19:31 it can recurse through a directory of modules, or take a list of classes 19:31 for starters, role support 19:31 i know how to do it 19:31 but haven't yet 19:32 type constraint support is very primitive 19:32 is that essentially the same code sartak needs to write to give Mouse roles? 19:32 i don't know what that is but doesn't sound likely 19:32 in MXC moose has already done the role composition 19:32 i just need to figure where the data came from, load that file and realias the subs 19:33 (at bootstrap time) 19:33 no role composition per se 19:33 it's nice to make clear that MXC has two "levels" of awesome 19:33 so you can figure out what you can hope to achieve 19:34 100% compiled everything means you don't load Moose or Class::MOP 19:34 until you need runtime reflection 19:34 no codegen at compile time 19:34 it should load as fast as hand written code 19:34 i've had it beating Object::Tiny in some benchmarks =) 19:35 oo 19:35 Moose::XS should aid in making MooseX::Compile's supported feature set easier 19:35 the less awesome level of awesome is just some classes 19:35 you don't pay for those classes' compilation (Role composition, etc) 19:35 (especially since for me perl -MMoose -e1 takes up 50% of "sd help"'s runtime 19:36 (.4s here) 19:36 5.8.8/ 19:36 ? 19:36 yeah 19:36 "that's what's in the wild" 19:36 i'm just curious if it makes a dfif 19:36 * obra nods 19:36 I don't have my macbook right now or I'd test 19:36 trunk moose loads slower 19:36 how much slower? 19:36 but 5.10 loads faster 19:36 negligiably 19:36 i think like 10% 19:36 this was trunk moose as of friday 19:36 but we can fix that 19:36 ah 19:36 my tests aren't scientific. 19:36 trunk moose as of you sending me nytprofs 19:37 actually that's CPAN moose now 19:37 0.35 - 0.45 19:37 ouch 19:37 well, part of the problem is that it loads *EVERYTHING* 19:37 every type of meta method class, meta type constraint, the role system, etc 19:37 for a big app these probably will get loaded 19:38 but for a small app, especially if you load the various sub modules only as needed, you shouldn't pay for these 19:38 that's a trivial fix that perigrin started working on 19:38 yeah. I played with his branch and saw no change as of last night 19:39 so yeah, we're using roles. if roles aren't ready yet, I won't get far at all. 19:39 (Also, I do really appreciate all the work you're doing. That I'm not paying for, even ;) 19:39 Thank you. 19:39 i will try shaving Moose's own load time with a profile based approach 19:39 It's SO MUCH better than it was 19:39 well, everybody wins =) 19:39 a. you're a friend 19:40 b. part of my job is making Moose work well 19:40 c. your using Moose helps moose directly and indirectly 19:40 d. I LIKE TACOS 19:40 erm, i mean sushi 19:40 so no worries on that 19:41 so, long term goals: 19:41 App::SD etc has all the meta calculations already cached in .mopc and .pmc 19:41 moose is not loaded 19:41 all generated code is cached 19:41 at worst Moose::XS is loaded to install subs with newXS 19:41 that would be really cool 19:41 depending on which actually fairs better 19:42 that goal is realistic, but involves a lot of work 19:42 more realistic short term goals: 19:42 I started playing with try to dump the symbol table, etc 19:42 MooseX::Compile partly speeding up SD 19:42 we can incrementally improve on that 19:42 and found that DD::Streamer is a lot closer than anything has ever been, but it craps out around not being able to dump lvalue subs 19:43 Moose::XS replacing some code gen 19:43 yes, the initial approach was to to try and marshall Moose classes into DDS 19:43 but it wasn't stable enough 19:43 and also there's the problem of imports 19:43 you must serialize the whole table at once 19:43 or manage an intricate web of inter dependencies 19:43 * obra nods 19:44 i sort of work around that by making all the require()/use() statements stay verbatim 19:44 also it doesn't handle xsubs 19:44 how hard would it be to get moose's codegen to write out source code instead of blowing subs into memory? 19:44 so there's guesswork for where ::bootstrap was called 19:44 i was just getting to that = 19:44 =) 19:44 pretty trivial 19:44 heh 19:44 just grunt work 19:44 is that a more viable approach? 19:44 it's one of the limiting parts of MooseX::Compile 19:45 if we clean up that code it will be easier to add support for more features 19:45 but it's not a huge hurdle since it's a very contained problem 19:45 it doesn't directly affect the design of MXC 19:45 is this stuff written down anywhere other than this buffer? 19:45 i don't think so 19:46 where should it get pasted? 19:46 good question =) 19:46 i think #moose-dev is pretty aware 19:46 is there a moose wiki? 19:46 but documenting is good for people to help out 19:46 no, there should be 19:46 yeah. but the goal is to turn it into written docs. 19:46 ok. for now, it should end up in MooseX-Compile/doc/design 19:46 sounds good 19:46 . o O { Thank god I don't have a moose commit bit } 19:47 though most of this affects moose itself though 19:47 * obra nods 19:47 Moose/doc/moosex-compile, then GitUpToDate.pm100644000767000024 137212200352344 15577 0ustar00etherstaff000000000000Moose-2.1005/incpackage inc::GitUpToDate; use Moose; with 'Dist::Zilla::Role::BeforeBuild'; sub git { if (wantarray) { chomp(my @ret = qx{git $_[0]}); return @ret; } else { chomp(my $ret = qx{git $_[0]}); return $ret; } } sub before_build { my $self = shift; return unless $ENV{DZIL_RELEASING}; my $branch = git "symbolic-ref HEAD"; die "Could not get the current branch" unless $branch; $branch =~ s{refs/heads/}{}; $self->log("Ensuring branch $branch is up to date"); git "fetch origin"; my $origin = git "rev-parse origin/$branch"; my $head = git "rev-parse HEAD"; die "Branch $branch is not up to date (origin: $origin, HEAD: $head)" if $origin ne $head; } 1; TestRelease.pm100644000767000024 60412200352344 15643 0ustar00etherstaff000000000000Moose-2.1005/incpackage inc::TestRelease; use Moose; extends 'Dist::Zilla::Plugin::TestRelease'; around before_release => sub { my $orig = shift; my $self = shift; local $ENV{MOOSE_TEST_MD} = $self->zilla->is_trial ? $ENV{MOOSE_TEST_MD} : 1; local $ENV{AUTHOR_TESTING} = $self->zilla->is_trial ? $ENV{AUTHOR_TESTING} : 1; $self->$orig(@_); }; 1; methods.t100644000767000024 155312200352344 15677 0ustar00etherstaff000000000000Moose-2.1005/t/basics#!/usr/bin/perl use strict; use warnings; use Test::More; my $test1 = Moose::Meta::Class->create_anon_class; $test1->add_method( 'foo1', sub { } ); my $t1 = $test1->new_object; my $t1_am = $t1->meta->get_method('foo1')->associated_metaclass; ok( $t1_am, 'associated_metaclass is defined' ); isa_ok( $t1_am, 'Moose::Meta::Class', 'associated_metaclass is correct class' ); like( $t1_am->name(), qr/::__ANON__::/, 'associated_metaclass->name looks like an anonymous class' ); { package Test2; use Moose; sub foo2 { } } my $t2 = Test2->new; my $t2_am = $t2->meta->get_method('foo2')->associated_metaclass; ok( $t2_am, 'associated_metaclass is defined' ); isa_ok( $t2_am, 'Moose::Meta::Class', 'associated_metaclass is correct class' ); is( $t2_am->name(), 'Test2', 'associated_metaclass->name is Test2' ); done_testing; rebless.t100644000767000024 654412200352344 15700 0ustar00etherstaff000000000000Moose-2.1005/t/basics#!/usr/bin/perl use strict; use warnings; use Test::More; use Test::Fatal; use Test::Moose qw(with_immutable); use Scalar::Util 'blessed'; use Moose::Util::TypeConstraints; subtype 'Positive' => as 'Num' => where { $_ > 0 }; { package Parent; use Moose; has name => ( is => 'rw', isa => 'Str', ); has lazy_classname => ( is => 'ro', lazy => 1, default => sub { "Parent" }, ); has type_constrained => ( is => 'rw', isa => 'Num', default => 5.5, ); package Child; use Moose; extends 'Parent'; has '+name' => ( default => 'Junior', ); has '+lazy_classname' => ( default => sub {"Child"}, ); has '+type_constrained' => ( isa => 'Int', default => 100, ); our %trigger_calls; our %initializer_calls; has new_attr => ( is => 'rw', isa => 'Str', trigger => sub { my ( $self, $val, $attr ) = @_; $trigger_calls{new_attr}++; }, initializer => sub { my ( $self, $value, $set, $attr ) = @_; $initializer_calls{new_attr}++; $set->($value); }, ); } my @classes = qw(Parent Child); with_immutable { my $foo = Parent->new; my $bar = Parent->new; is( blessed($foo), 'Parent', 'Parent->new gives a Parent object' ); is( $foo->name, undef, 'No name yet' ); is( $foo->lazy_classname, 'Parent', "lazy attribute initialized" ); is( exception { $foo->type_constrained(10.5) }, undef, "Num type constraint for now.." ); # try to rebless, except it will fail due to Child's stricter type constraint like( exception { Child->meta->rebless_instance($foo) }, qr/^Attribute \(type_constrained\) does not pass the type constraint because\: Validation failed for 'Int' with value 10\.5/, '... this failed because of type check' ); like( exception { Child->meta->rebless_instance($bar) }, qr/^Attribute \(type_constrained\) does not pass the type constraint because\: Validation failed for 'Int' with value 5\.5/, '... this failed because of type check' ); $foo->type_constrained(10); $bar->type_constrained(5); Child->meta->rebless_instance($foo); Child->meta->rebless_instance( $bar, new_attr => 'blah' ); is( blessed($foo), 'Child', 'successfully reblessed into Child' ); is( $foo->name, 'Junior', "Child->name's default came through" ); is( $foo->lazy_classname, 'Parent', "lazy attribute was already initialized" ); is( $bar->lazy_classname, 'Child', "lazy attribute just now initialized" ); like( exception { $foo->type_constrained(10.5) }, qr/^Attribute \(type_constrained\) does not pass the type constraint because\: Validation failed for 'Int' with value 10\.5/, '... this failed because of type check' ); is_deeply( \%Child::trigger_calls, { new_attr => 1 }, 'Trigger fired on rebless_instance' ); is_deeply( \%Child::initializer_calls, { new_attr => 1 }, 'Initializer fired on rebless_instance' ); undef %Child::trigger_calls; undef %Child::initializer_calls; } @classes; done_testing; attribute.t100644000767000024 2126712200352344 15755 0ustar00etherstaff000000000000Moose-2.1005/t/cmopuse strict; use warnings; use Scalar::Util 'reftype', 'blessed'; use Test::More; use Test::Fatal; use Class::MOP; use Class::MOP::Attribute; use Class::MOP::Method; isnt( exception { Class::MOP::Attribute->name }, undef, q{... can't call name() as a class method} ); { my $attr = Class::MOP::Attribute->new('$foo'); isa_ok($attr, 'Class::MOP::Attribute'); is($attr->name, '$foo', '... $attr->name == $foo'); ok($attr->has_init_arg, '... $attr does have an init_arg'); is($attr->init_arg, '$foo', '... $attr init_arg is the name'); ok(!$attr->has_accessor, '... $attr does not have an accessor'); ok(!$attr->has_reader, '... $attr does not have an reader'); ok(!$attr->has_writer, '... $attr does not have an writer'); ok(!$attr->has_default, '... $attr does not have an default'); ok(!$attr->has_builder, '... $attr does not have a builder'); { my $reader = $attr->get_read_method_ref; my $writer = $attr->get_write_method_ref; ok(!blessed($reader), '... it is a plain old sub'); ok(!blessed($writer), '... it is a plain old sub'); is(reftype($reader), 'CODE', '... it is a plain old sub'); is(reftype($writer), 'CODE', '... it is a plain old sub'); } my $class = Class::MOP::Class->initialize('Foo'); isa_ok($class, 'Class::MOP::Class'); is( exception { $attr->attach_to_class($class); }, undef, '... attached a class successfully' ); is($attr->associated_class, $class, '... the class was associated correctly'); ok(!$attr->get_read_method, '... $attr does not have an read method'); ok(!$attr->get_write_method, '... $attr does not have an write method'); { my $reader = $attr->get_read_method_ref; my $writer = $attr->get_write_method_ref; ok(blessed($reader), '... it is a plain old sub'); ok(blessed($writer), '... it is a plain old sub'); isa_ok($reader, 'Class::MOP::Method'); isa_ok($writer, 'Class::MOP::Method'); } my $attr_clone = $attr->clone(); isa_ok($attr_clone, 'Class::MOP::Attribute'); isnt($attr, $attr_clone, '... but they are different instances'); is($attr->associated_class, $attr_clone->associated_class, '... the associated classes are the same though'); is($attr->associated_class, $class, '... the associated classes are the same though'); is($attr_clone->associated_class, $class, '... the associated classes are the same though'); is_deeply($attr, $attr_clone, '... but they are the same inside'); } { my $attr = Class::MOP::Attribute->new('$foo', ( init_arg => '-foo', default => 'BAR' )); isa_ok($attr, 'Class::MOP::Attribute'); is($attr->name, '$foo', '... $attr->name == $foo'); ok($attr->has_init_arg, '... $attr does have an init_arg'); is($attr->init_arg, '-foo', '... $attr->init_arg == -foo'); ok($attr->has_default, '... $attr does have an default'); is($attr->default, 'BAR', '... $attr->default == BAR'); ok(!$attr->has_builder, '... $attr does not have a builder'); ok(!$attr->has_accessor, '... $attr does not have an accessor'); ok(!$attr->has_reader, '... $attr does not have an reader'); ok(!$attr->has_writer, '... $attr does not have an writer'); ok(!$attr->get_read_method, '... $attr does not have an read method'); ok(!$attr->get_write_method, '... $attr does not have an write method'); { my $reader = $attr->get_read_method_ref; my $writer = $attr->get_write_method_ref; ok(!blessed($reader), '... it is a plain old sub'); ok(!blessed($writer), '... it is a plain old sub'); is(reftype($reader), 'CODE', '... it is a plain old sub'); is(reftype($writer), 'CODE', '... it is a plain old sub'); } my $attr_clone = $attr->clone(); isa_ok($attr_clone, 'Class::MOP::Attribute'); isnt($attr, $attr_clone, '... but they are different instances'); is($attr->associated_class, $attr_clone->associated_class, '... the associated classes are the same though'); is($attr->associated_class, undef, '... the associated class is actually undef'); is($attr_clone->associated_class, undef, '... the associated class is actually undef'); is_deeply($attr, $attr_clone, '... but they are the same inside'); } { my $attr = Class::MOP::Attribute->new('$foo', ( accessor => 'foo', init_arg => '-foo', default => 'BAR' )); isa_ok($attr, 'Class::MOP::Attribute'); is($attr->name, '$foo', '... $attr->name == $foo'); ok($attr->has_init_arg, '... $attr does have an init_arg'); is($attr->init_arg, '-foo', '... $attr->init_arg == -foo'); ok($attr->has_default, '... $attr does have an default'); is($attr->default, 'BAR', '... $attr->default == BAR'); ok($attr->has_accessor, '... $attr does have an accessor'); is($attr->accessor, 'foo', '... $attr->accessor == foo'); ok(!$attr->has_reader, '... $attr does not have an reader'); ok(!$attr->has_writer, '... $attr does not have an writer'); is($attr->get_read_method, 'foo', '... $attr does not have an read method'); is($attr->get_write_method, 'foo', '... $attr does not have an write method'); { my $reader = $attr->get_read_method_ref; my $writer = $attr->get_write_method_ref; ok(!blessed($reader), '... it is not a plain old sub'); ok(!blessed($writer), '... it is not a plain old sub'); is(reftype($reader), 'CODE', '... it is a plain old sub'); is(reftype($writer), 'CODE', '... it is a plain old sub'); } my $attr_clone = $attr->clone(); isa_ok($attr_clone, 'Class::MOP::Attribute'); isnt($attr, $attr_clone, '... but they are different instances'); is_deeply($attr, $attr_clone, '... but they are the same inside'); } { my $attr = Class::MOP::Attribute->new('$foo', ( reader => 'get_foo', writer => 'set_foo', init_arg => '-foo', default => 'BAR' )); isa_ok($attr, 'Class::MOP::Attribute'); is($attr->name, '$foo', '... $attr->name == $foo'); ok($attr->has_init_arg, '... $attr does have an init_arg'); is($attr->init_arg, '-foo', '... $attr->init_arg == -foo'); ok($attr->has_default, '... $attr does have an default'); is($attr->default, 'BAR', '... $attr->default == BAR'); ok($attr->has_reader, '... $attr does have an reader'); is($attr->reader, 'get_foo', '... $attr->reader == get_foo'); ok($attr->has_writer, '... $attr does have an writer'); is($attr->writer, 'set_foo', '... $attr->writer == set_foo'); ok(!$attr->has_accessor, '... $attr does not have an accessor'); is($attr->get_read_method, 'get_foo', '... $attr does not have an read method'); is($attr->get_write_method, 'set_foo', '... $attr does not have an write method'); { my $reader = $attr->get_read_method_ref; my $writer = $attr->get_write_method_ref; ok(!blessed($reader), '... it is not a plain old sub'); ok(!blessed($writer), '... it is not a plain old sub'); is(reftype($reader), 'CODE', '... it is a plain old sub'); is(reftype($writer), 'CODE', '... it is a plain old sub'); } my $attr_clone = $attr->clone(); isa_ok($attr_clone, 'Class::MOP::Attribute'); isnt($attr, $attr_clone, '... but they are different instances'); is_deeply($attr, $attr_clone, '... but they are the same inside'); } { my $attr = Class::MOP::Attribute->new('$foo'); isa_ok($attr, 'Class::MOP::Attribute'); my $attr_clone = $attr->clone('name' => '$bar'); isa_ok($attr_clone, 'Class::MOP::Attribute'); isnt($attr, $attr_clone, '... but they are different instances'); isnt($attr->name, $attr_clone->name, '... we changes the name parameter'); is($attr->name, '$foo', '... $attr->name == $foo'); is($attr_clone->name, '$bar', '... $attr_clone->name == $bar'); } { my $attr = Class::MOP::Attribute->new('$foo', (builder => 'foo_builder')); isa_ok($attr, 'Class::MOP::Attribute'); ok(!$attr->has_default, '... $attr does not have a default'); ok($attr->has_builder, '... $attr does have a builder'); is($attr->builder, 'foo_builder', '... $attr->builder == foo_builder'); } { for my $value ({}, bless({}, 'Foo')) { like( exception { Class::MOP::Attribute->new('$foo', default => $value); }, qr/References are not allowed as default values/ ); } } { my $attr; is( exception { my $meth = Class::MOP::Method->wrap(sub {shift}, name => 'foo', package_name => 'bar'); $attr = Class::MOP::Attribute->new('$foo', default => $meth); }, undef, 'Class::MOP::Methods accepted as default' ); is($attr->default(42), 42, 'passthrough for default on attribute'); } done_testing; metaclass.t100644000767000024 217712200352344 15705 0ustar00etherstaff000000000000Moose-2.1005/t/cmopuse strict; use warnings; use Test::More; use metaclass; { package FooMeta; use base 'Class::MOP::Class'; package Foo; use metaclass 'FooMeta'; } can_ok('Foo', 'meta'); isa_ok(Foo->meta, 'FooMeta'); isa_ok(Foo->meta, 'Class::MOP::Class'); { package BarMeta; use base 'Class::MOP::Class'; package BarMeta::Attribute; use base 'Class::MOP::Attribute'; package BarMeta::Method; use base 'Class::MOP::Method'; package Bar; use metaclass 'BarMeta' => ( 'attribute_metaclass' => 'BarMeta::Attribute', 'method_metaclass' => 'BarMeta::Method', ); } can_ok('Bar', 'meta'); isa_ok(Bar->meta, 'BarMeta'); isa_ok(Bar->meta, 'Class::MOP::Class'); is(Bar->meta->attribute_metaclass, 'BarMeta::Attribute', '... got the right attribute metaobject'); is(Bar->meta->method_metaclass, 'BarMeta::Method', '... got the right method metaobject'); { package Baz; use metaclass; } can_ok('Baz', 'meta'); isa_ok(Baz->meta, 'Class::MOP::Class'); eval { package Boom; metaclass->import('Foo'); }; ok($@, '... metaclasses must be subclass of Class::MOP::Class'); done_testing; bin000755000767000024 012200352344 12744 5ustar00etherstaff000000000000Moose-2.1005moose-outdated100644000767000024 55612200352344 15746 0ustar00etherstaff000000000000Moose-2.1005/bin#!/usr/bin/perl use strict; use warnings; # PODNAME: moose-outdated use Getopt::Long; use Moose::Conflicts; my $verbose; GetOptions( 'verbose|v' => \$verbose ); if ($verbose) { Moose::Conflicts->check_conflicts; } else { my @conflicts = Moose::Conflicts->calculate_conflicts; print "$_\n" for map { $_->{package} } @conflicts; exit @conflicts; } eg000755000767000024 012200352344 12567 5ustar00etherstaff000000000000Moose-2.1005class_browser.pl100644000767000024 1712512200352344 16162 0ustar00etherstaff000000000000Moose-2.1005/eg#!/usr/bin/perl use strict; use warnings; use Data::Dumper; use B::Deparse; use Template; use Getopt::Long; use CGI; use Class::MOP; my $stand_alone = 0; GetOptions("s" => \$stand_alone); if ($stand_alone) { require HTTP::Server::Simple::CGI; { package # hide me from PAUSE Class::MOP::Browser::Server; our @ISA = qw(HTTP::Server::Simple::CGI); sub handle_request { ::process_template() } } Class::MOP::Browser::Server->new()->run(); } else { print CGI::header(); process_template(); } { my $DATA; sub process_template { $DATA ||= join "" => ; Template->new->process( \$DATA, { 'get_all_metaclasses' => \&::get_all_metaclasses, 'get_metaclass_by_name' => \&::get_metaclass_by_name, 'deparse_method' => \&::deparse_method, 'deparse_item' => \&::deparse_item, } ) or warn Template->error; } } sub get_all_metaclasses { sort { $a->name cmp $b->name } Class::MOP::get_all_metaclass_instances() } sub get_metaclass_by_name { Class::MOP::get_metaclass_by_name(@_); } sub deparse_method { my ($method) = @_; my $deparse = B::Deparse->new("-d"); my $body = $deparse->coderef2text($method->body()); return "sub " . $method->name . ' ' . _clean_deparse_code($body); } sub deparse_item { my ($item) = @_; return $item unless ref $item; local $Data::Dumper::Deparse = 1; local $Data::Dumper::Indent = 1; my $dumped = Dumper $item; $dumped =~ s/^\$VAR1\s=\s//; $dumped =~ s/\;$//; return _clean_deparse_code($dumped); } sub _clean_deparse_code { my @body = split /\n/ => $_[0]; my @cleaned; foreach (@body) { next if /^\s+use/; next if /^\s+BEGIN/; next if /^\s+package/; push @cleaned => $_; } return (join "\n" => @cleaned); } 1; ## This is the template file to be used __DATA__ [% USE q = CGI %] [% area = 'attributes' %] [% IF q.param('area') %] [% area = q.param('area') %] [% END %] Class::MOP Browser

Class::MOP Browser

[% IF q.param('class') && area %] [% meta = get_metaclass_by_name(q.param('class')) %] [% END %]
[% FOREACH metaclass IN get_all_metaclasses() %] [% IF q.param('class') == metaclass.name %] [% ELSE %] [% END %] [% END %]
[% metaclass.name %][% metaclass.name %]
 [% FOREACH area_name IN [ 'attributes', 'methods', 'superclasses' ] %] [% IF q.param('class') %] [% IF area == area_name %] [% ELSE %] [% END %] [% ELSE %] [% END %] [% END %]
[% area_name %][% area_name %][% area_name %]
 [% IF q.param('class') && area == 'attributes' && q.param('attr') %] [% meta = get_metaclass_by_name(q.param('class')) attr = meta.get_attribute(q.param('attr')) %] [% FOREACH aspect IN [ 'name', 'init_arg', 'reader', 'writer', 'accessor', 'predicate', 'default' ]%] [% item = attr.$aspect() %] [% END %] [% ELSIF q.param('class') && area == 'methods' && q.param('method') %] [% meta = get_metaclass_by_name(q.param('class')) method = meta.get_method(q.param('method')) %] [% FOREACH aspect IN [ 'name', 'package_name', 'fully_qualified_name' ]%] [% END %] [% END %]
[% aspect %] [% IF item == undef %]—[% ELSE %]
[% deparse_item(item) %]
[% END %]
[% aspect %] [% method.$aspect() %]
body 
[% deparse_method(method) %]
[% IF area == 'methods' %] [% FOREACH method IN meta.get_method_list.sort %] [% IF q.param('method') == method %] [% ELSE %] [% END %] [% END %] [% END %] [% IF area == 'attributes' %] [% FOREACH attr IN meta.get_attribute_list.sort %] [% IF q.param('attr') == attr %] [% ELSE %] [% END %] [% END %] [% END %] [% IF area == 'superclasses' %] [% FOREACH super IN meta.superclasses.sort %] [% END %] [% END %]
[% method %][% method %]
[% attr %][% attr %]
[% super %]
Intro.pod100644000767000024 140512200352344 15763 0ustar00etherstaff000000000000Moose-2.1005/lib/Moosepackage Moose::Intro; # ABSTRACT: Expanded into Moose::Manual, so go read that __END__ =pod =head1 NAME Moose::Intro - Expanded into Moose::Manual, so go read that =head1 VERSION version 2.1005 =head1 DESCRIPTION The intro has been replaced by L. This POD document still exists for the benefit of anyone out there who might've linked to it in the past. =head1 AUTHOR Moose is maintained by the Moose Cabal, along with the help of many contributors. See L and L for details. =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2013 by Infinity Interactive, Inc.. This is free software; you can redistribute it and/or modify it under the same terms as the Perl 5 programming language system itself. =cut Object.pm100644000767000024 1360412200352344 15754 0ustar00etherstaff000000000000Moose-2.1005/lib/Moose package Moose::Object; BEGIN { $Moose::Object::AUTHORITY = 'cpan:STEVAN'; } { $Moose::Object::VERSION = '2.1005'; } use strict; use warnings; use Carp (); use Devel::GlobalDestruction (); use MRO::Compat (); use Scalar::Util (); use Try::Tiny (); use if ( not our $__mx_is_compiled ), 'Moose::Meta::Class'; use if ( not our $__mx_is_compiled ), metaclass => 'Moose::Meta::Class'; sub new { my $class = shift; my $real_class = Scalar::Util::blessed($class) || $class; my $params = $real_class->BUILDARGS(@_); return Class::MOP::Class->initialize($real_class)->new_object($params); } sub BUILDARGS { my $class = shift; if ( scalar @_ == 1 ) { unless ( defined $_[0] && ref $_[0] eq 'HASH' ) { Class::MOP::class_of($class)->throw_error( "Single parameters to new() must be a HASH ref", data => $_[0] ); } return { %{ $_[0] } }; } elsif ( @_ % 2 ) { Carp::carp( "The new() method for $class expects a hash reference or a key/value list." . " You passed an odd number of arguments" ); return { @_, undef }; } else { return {@_}; } } sub BUILDALL { # NOTE: we ask Perl if we even # need to do this first, to avoid # extra meta level calls return unless $_[0]->can('BUILD'); my ($self, $params) = @_; foreach my $method (reverse Class::MOP::class_of($self)->find_all_methods_by_name('BUILD')) { $method->{code}->execute($self, $params); } } sub DEMOLISHALL { my $self = shift; my ($in_global_destruction) = @_; # NOTE: we ask Perl if we even # need to do this first, to avoid # extra meta level calls return unless $self->can('DEMOLISH'); my @isa; if ( my $meta = Class::MOP::class_of($self ) ) { @isa = $meta->linearized_isa; } else { # We cannot count on being able to retrieve a previously made # metaclass, _or_ being able to make a new one during global # destruction. However, we should still be able to use mro at # that time (at least tests suggest so ;) my $class_name = ref $self; @isa = @{ mro::get_linear_isa($class_name) } } foreach my $class (@isa) { no strict 'refs'; my $demolish = *{"${class}::DEMOLISH"}{CODE}; $self->$demolish($in_global_destruction) if defined $demolish; } } sub DESTROY { my $self = shift; local $?; Try::Tiny::try { $self->DEMOLISHALL(Devel::GlobalDestruction::in_global_destruction); } Try::Tiny::catch { die $_; }; return; } # support for UNIVERSAL::DOES ... BEGIN { my $does = UNIVERSAL->can("DOES") ? "SUPER::DOES" : "isa"; eval 'sub DOES { my ( $self, $class_or_role_name ) = @_; return $self->'.$does.'($class_or_role_name) || $self->does($class_or_role_name); }'; } # new does() methods will be created # as appropriate see Moose::Meta::Role sub does { my ($self, $role_name) = @_; my $class = Scalar::Util::blessed($self) || $self; my $meta = Class::MOP::Class->initialize($class); (defined $role_name) || $meta->throw_error("You must supply a role name to does()"); return 1 if $meta->can('does_role') && $meta->does_role($role_name); return 0; } sub dump { my $self = shift; require Data::Dumper; local $Data::Dumper::Maxdepth = shift if @_; Data::Dumper::Dumper $self; } 1; # ABSTRACT: The base object for Moose __END__ =pod =head1 NAME Moose::Object - The base object for Moose =head1 VERSION version 2.1005 =head1 DESCRIPTION This class is the default base class for all Moose-using classes. When you C in this class, your class will inherit from this class. It provides a default constructor and destructor, which run all of the C and C methods in the inheritance hierarchy, respectively. You don't actually I to inherit from this in order to use Moose, but it makes it easier to take advantage of all of Moose's features. =head1 METHODS =over 4 =item B<< Moose::Object->new(%params|$params) >> This method calls C<< $class->BUILDARGS(@_) >>, and then creates a new instance of the appropriate class. Once the instance is created, it calls C<< $instance->BUILD($params) >> for each C method in the inheritance hierarchy. =item B<< Moose::Object->BUILDARGS(%params|$params) >> The default implementation of this method accepts a hash or hash reference of named parameters. If it receives a single argument that I a hash reference it throws an error. You can override this method in your class to handle other types of options passed to the constructor. This method should always return a hash reference of named options. =item B<< $object->does($role_name) >> This returns true if the object does the given role. =item B<< $object->DOES($class_or_role_name) >> This is a Moose role-aware implementation of L. This is effectively the same as writing: $object->does($name) || $object->isa($name) This method will work with Perl 5.8, which did not implement C. =item B<< $object->dump($maxdepth) >> This is a handy utility for Cing an object. By default, the maximum depth is 1, to avoid making a mess. =item B<< $object->DESTROY >> A default destructor is provided, which calls C<< $instance->DEMOLISH($in_global_destruction) >> for each C method in the inheritance hierarchy. =back =head1 BUGS See L for details on reporting bugs. =head1 AUTHOR Moose is maintained by the Moose Cabal, along with the help of many contributors. See L and L for details. =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2013 by Infinity Interactive, Inc.. This is free software; you can redistribute it and/or modify it under the same terms as the Perl 5 programming language system itself. =cut anon_class.t100644000767000024 441512200352344 16046 0ustar00etherstaff000000000000Moose-2.1005/t/cmopuse strict; use warnings; use Test::More; use Test::Fatal; use Class::MOP; { package Foo; use strict; use warnings; use metaclass; sub bar { 'Foo::bar' } } my $anon_class_id; { my $instance; { my $anon_class = Class::MOP::Class->create_anon_class(); isa_ok($anon_class, 'Class::MOP::Class'); ($anon_class_id) = ($anon_class->name =~ /Class::MOP::Class::__ANON__::SERIAL::(\d+)/); ok(exists $main::Class::MOP::Class::__ANON__::SERIAL::{$anon_class_id . '::'}, '... the package exists'); like($anon_class->name, qr/Class::MOP::Class::__ANON__::SERIAL::[0-9]+/, '... got an anon class package name'); is_deeply( [$anon_class->superclasses], [], '... got an empty superclass list'); is( exception { $anon_class->superclasses('Foo'); }, undef, '... can add a superclass to anon class' ); is_deeply( [$anon_class->superclasses], [ 'Foo' ], '... got the right superclass list'); ok(!$anon_class->has_method('foo'), '... no foo method'); is( exception { $anon_class->add_method('foo' => sub { "__ANON__::foo" }); }, undef, '... added a method to my anon-class' ); ok($anon_class->has_method('foo'), '... we have a foo method now'); $instance = $anon_class->new_object(); isa_ok($instance, $anon_class->name); isa_ok($instance, 'Foo'); is($instance->foo, '__ANON__::foo', '... got the right return value of our foo method'); is($instance->bar, 'Foo::bar', '... got the right return value of our bar method'); } ok(exists $main::Class::MOP::Class::__ANON__::SERIAL::{$anon_class_id . '::'}, '... the package still exists'); } ok(!exists $main::Class::MOP::Class::__ANON__::SERIAL::{$anon_class_id . '::'}, '... the package no longer exists'); # but it breaks down when we try to create another one ... my $instance_2 = bless {} => ('Class::MOP::Class::__ANON__::SERIAL::' . $anon_class_id); isa_ok($instance_2, ('Class::MOP::Class::__ANON__::SERIAL::' . $anon_class_id)); ok(!$instance_2->isa('Foo'), '... but the new instance is not a Foo'); ok(!$instance_2->can('foo'), '... and it can no longer call the foo method'); done_testing; attributes.t100644000767000024 2164412200352344 16137 0ustar00etherstaff000000000000Moose-2.1005/t/cmopuse strict; use warnings; use Test::More; use Test::Fatal; use Class::MOP; my $FOO_ATTR = Class::MOP::Attribute->new('$foo'); my $BAR_ATTR = Class::MOP::Attribute->new('$bar' => ( accessor => 'bar' )); my $BAZ_ATTR = Class::MOP::Attribute->new('$baz' => ( reader => 'get_baz', writer => 'set_baz', )); my $BAR_ATTR_2 = Class::MOP::Attribute->new('$bar'); my $FOO_ATTR_2 = Class::MOP::Attribute->new('$foo' => ( accessor => 'foo', builder => 'build_foo' )); is($FOO_ATTR->name, '$foo', '... got the attributes name correctly'); is($BAR_ATTR->name, '$bar', '... got the attributes name correctly'); is($BAZ_ATTR->name, '$baz', '... got the attributes name correctly'); { package Foo; use metaclass; my $meta = Foo->meta; ::is( ::exception { $meta->add_attribute($FOO_ATTR); }, undef, '... we added an attribute to Foo successfully' ); ::ok($meta->has_attribute('$foo'), '... Foo has $foo attribute'); ::is($meta->get_attribute('$foo'), $FOO_ATTR, '... got the right attribute back for Foo'); ::ok(!$meta->has_method('foo'), '... no accessor created'); ::is( ::exception { $meta->add_attribute($BAR_ATTR_2); }, undef, '... we added an attribute to Foo successfully' ); ::ok($meta->has_attribute('$bar'), '... Foo has $bar attribute'); ::is($meta->get_attribute('$bar'), $BAR_ATTR_2, '... got the right attribute back for Foo'); ::ok(!$meta->has_method('bar'), '... no accessor created'); } { package Bar; our @ISA = ('Foo'); my $meta = Bar->meta; ::is( ::exception { $meta->add_attribute($BAR_ATTR); }, undef, '... we added an attribute to Bar successfully' ); ::ok($meta->has_attribute('$bar'), '... Bar has $bar attribute'); ::is($meta->get_attribute('$bar'), $BAR_ATTR, '... got the right attribute back for Bar'); my $attr = $meta->get_attribute('$bar'); ::is($attr->get_read_method, 'bar', '... got the right read method for Bar'); ::is($attr->get_write_method, 'bar', '... got the right write method for Bar'); ::ok($meta->has_method('bar'), '... an accessor has been created'); ::isa_ok($meta->get_method('bar'), 'Class::MOP::Method::Accessor'); } { package Baz; our @ISA = ('Bar'); my $meta = Baz->meta; ::is( ::exception { $meta->add_attribute($BAZ_ATTR); }, undef, '... we added an attribute to Baz successfully' ); ::ok($meta->has_attribute('$baz'), '... Baz has $baz attribute'); ::is($meta->get_attribute('$baz'), $BAZ_ATTR, '... got the right attribute back for Baz'); my $attr = $meta->get_attribute('$baz'); ::is($attr->get_read_method, 'get_baz', '... got the right read method for Baz'); ::is($attr->get_write_method, 'set_baz', '... got the right write method for Baz'); ::ok($meta->has_method('get_baz'), '... a reader has been created'); ::ok($meta->has_method('set_baz'), '... a writer has been created'); ::isa_ok($meta->get_method('get_baz'), 'Class::MOP::Method::Accessor'); ::isa_ok($meta->get_method('set_baz'), 'Class::MOP::Method::Accessor'); } { package Foo2; use metaclass; my $meta = Foo2->meta; $meta->add_attribute( Class::MOP::Attribute->new( '$foo2' => ( reader => 'foo2' ) ) ); ::ok( $meta->has_method('foo2'), '... a reader has been created' ); my $attr = $meta->get_attribute('$foo2'); ::is( $attr->get_read_method, 'foo2', '... got the right read method for Foo2' ); ::is( $attr->get_write_method, undef, '... got undef for the writer with a read-only attribute in Foo2' ); } { my $meta = Baz->meta; isa_ok($meta, 'Class::MOP::Class'); is($meta->find_attribute_by_name('$bar'), $BAR_ATTR, '... got the right attribute for "bar"'); is($meta->find_attribute_by_name('$baz'), $BAZ_ATTR, '... got the right attribute for "baz"'); is($meta->find_attribute_by_name('$foo'), $FOO_ATTR, '... got the right attribute for "foo"'); is_deeply( [ sort { $a->name cmp $b->name } $meta->get_all_attributes() ], [ $BAR_ATTR, $BAZ_ATTR, $FOO_ATTR, ], '... got the right list of applicable attributes for Baz'); is_deeply( [ map { $_->associated_class } sort { $a->name cmp $b->name } $meta->get_all_attributes() ], [ Bar->meta, Baz->meta, Foo->meta ], '... got the right list of associated classes from the applicable attributes for Baz'); my $attr; is( exception { $attr = $meta->remove_attribute('$baz'); }, undef, '... removed the $baz attribute successfully' ); is($attr, $BAZ_ATTR, '... got the right attribute back for Baz'); ok(!$meta->has_attribute('$baz'), '... Baz no longer has $baz attribute'); is($meta->get_attribute('$baz'), undef, '... Baz no longer has $baz attribute'); ok(!$meta->has_method('get_baz'), '... a reader has been removed'); ok(!$meta->has_method('set_baz'), '... a writer has been removed'); is_deeply( [ sort { $a->name cmp $b->name } $meta->get_all_attributes() ], [ $BAR_ATTR, $FOO_ATTR, ], '... got the right list of applicable attributes for Baz'); is_deeply( [ map { $_->associated_class } sort { $a->name cmp $b->name } $meta->get_all_attributes() ], [ Bar->meta, Foo->meta ], '... got the right list of associated classes from the applicable attributes for Baz'); { my $attr; is( exception { $attr = Bar->meta->remove_attribute('$bar'); }, undef, '... removed the $bar attribute successfully' ); is($attr, $BAR_ATTR, '... got the right attribute back for Bar'); ok(!Bar->meta->has_attribute('$bar'), '... Bar no longer has $bar attribute'); ok(!Bar->meta->has_method('bar'), '... a accessor has been removed'); } is_deeply( [ sort { $a->name cmp $b->name } $meta->get_all_attributes() ], [ $BAR_ATTR_2, $FOO_ATTR, ], '... got the right list of applicable attributes for Baz'); is_deeply( [ map { $_->associated_class } sort { $a->name cmp $b->name } $meta->get_all_attributes() ], [ Foo->meta, Foo->meta ], '... got the right list of associated classes from the applicable attributes for Baz'); # remove attribute which is not there my $val; is( exception { $val = $meta->remove_attribute('$blammo'); }, undef, '... attempted to remove the non-existent $blammo attribute' ); is($val, undef, '... got the right value back (undef)'); } { package Buzz; use metaclass; use Scalar::Util qw/blessed/; my $meta = Buzz->meta; ::is( ::exception { $meta->add_attribute($FOO_ATTR_2); }, undef, '... we added an attribute to Buzz successfully' ); ::is( ::exception { $meta->add_attribute( Class::MOP::Attribute->new( '$bar' => ( accessor => 'bar', predicate => 'has_bar', clearer => 'clear_bar', ) ) ); }, undef, '... we added an attribute to Buzz successfully' ); ::is( ::exception { $meta->add_attribute( Class::MOP::Attribute->new( '$bah' => ( accessor => 'bah', predicate => 'has_bah', clearer => 'clear_bah', default => 'BAH', ) ) ); }, undef, '... we added an attribute to Buzz successfully' ); ::is( ::exception { $meta->add_method(build_foo => sub{ blessed shift; }); }, undef, '... we added a method to Buzz successfully' ); } for(1 .. 2){ my $buzz; ::is( ::exception { $buzz = Buzz->meta->new_object }, undef, '...Buzz instantiated successfully' ); ::is($buzz->foo, 'Buzz', '...foo builder works as expected'); ::ok(!$buzz->has_bar, '...bar is not set'); ::is($buzz->bar, undef, '...bar returns undef'); ::ok(!$buzz->has_bar, '...bar was not autovivified'); $buzz->bar(undef); ::ok($buzz->has_bar, '...bar is set'); ::is($buzz->bar, undef, '...bar is undef'); $buzz->clear_bar; ::ok(!$buzz->has_bar, '...bar is no longerset'); my $buzz2; ::is( ::exception { $buzz2 = Buzz->meta->new_object('$bar' => undef) }, undef, '...Buzz instantiated successfully' ); ::ok($buzz2->has_bar, '...bar is set'); ::is($buzz2->bar, undef, '...bar is undef'); my $buzz3; ::is( ::exception { $buzz3 = Buzz->meta->new_object }, undef, '...Buzz instantiated successfully' ); ::ok($buzz3->has_bah, '...bah is set'); ::is($buzz3->bah, 'BAH', '...bah returns "BAH" '); my $buzz4; ::is( ::exception { $buzz4 = Buzz->meta->new_object('$bah' => undef) }, undef, '...Buzz instantiated successfully' ); ::ok($buzz4->has_bah, '...bah is set'); ::is($buzz4->bah, undef, '...bah is undef'); Buzz->meta->make_immutable(); } done_testing; deprecated.t100644000767000024 21612200352344 16001 0ustar00etherstaff000000000000Moose-2.1005/t/cmopuse strict; use warnings; use Test::More; use Test::Fatal; use Carp; $SIG{__WARN__} = \&croak; pass("nothing for now..."); done_testing; null_stash.t100644000767000024 34112200352344 16054 0ustar00etherstaff000000000000Moose-2.1005/t/cmop#!/usr/bin/env perl use strict; use warnings; use Test::More; use Class::MOP; my $non = Class::MOP::Class->initialize('Non::Existent::Package'); $non->get_method('foo'); pass("empty stashes don't segfault"); done_testing; subclasses.t100644000767000024 233112200352344 16070 0ustar00etherstaff000000000000Moose-2.1005/t/cmopuse strict; use warnings; use Test::More; use Class::MOP; do { package Grandparent; use metaclass; package Parent; use metaclass; use base 'Grandparent'; package Uncle; use metaclass; use base 'Grandparent'; package Son; use metaclass; use base 'Parent'; package Daughter; use metaclass; use base 'Parent'; package Cousin; use metaclass; use base 'Uncle'; }; is_deeply([sort Grandparent->meta->subclasses], ['Cousin', 'Daughter', 'Parent', 'Son', 'Uncle']); is_deeply([sort Parent->meta->subclasses], ['Daughter', 'Son']); is_deeply([sort Uncle->meta->subclasses], ['Cousin']); is_deeply([sort Son->meta->subclasses], []); is_deeply([sort Daughter->meta->subclasses], []); is_deeply([sort Cousin->meta->subclasses], []); is_deeply([sort Grandparent->meta->direct_subclasses], ['Parent', 'Uncle']); is_deeply([sort Parent->meta->direct_subclasses], ['Daughter', 'Son']); is_deeply([sort Uncle->meta->direct_subclasses], ['Cousin']); is_deeply([sort Son->meta->direct_subclasses], []); is_deeply([sort Daughter->meta->direct_subclasses], []); is_deeply([sort Cousin->meta->direct_subclasses], []); done_testing; MyExporter.pm100644000767000024 70312200352344 16001 0ustar00etherstaff000000000000Moose-2.1005/t/lib package MyExporter; use Moose::Exporter; use Test::More; Moose::Exporter->setup_import_methods( with_meta => [qw(with_prototype)], as_is => [qw(as_is_prototype)], ); sub with_prototype (&) { my ($class, $code) = @_; isa_ok($code, 'CODE', 'with_prototype received a coderef'); $code->(); } sub as_is_prototype (&) { my ($code) = @_; isa_ok($code, 'CODE', 'as_is_prototype received a coderef'); $code->(); } 1; Role000755000767000024 012200352344 14106 5ustar00etherstaff000000000000Moose-2.1005/t/libChild.pm100644000767000024 17612200352344 15613 0ustar00etherstaff000000000000Moose-2.1005/t/lib/Rolepackage Role::Child; use Moose::Role; with 'Role::Parent' => { -alias => { meth1 => 'aliased_meth1', } }; sub meth1 { } 1; meta_role.t100644000767000024 617612200352344 16071 0ustar00etherstaff000000000000Moose-2.1005/t/roles#!/usr/bin/perl use strict; use warnings; use Test::More; use Test::Fatal; use Moose::Meta::Role; use Moose::Util::TypeConstraints (); { package FooRole; our $VERSION = '0.01'; sub foo { 'FooRole::foo' } } my $foo_role = Moose::Meta::Role->initialize('FooRole'); isa_ok($foo_role, 'Moose::Meta::Role'); isa_ok($foo_role, 'Class::MOP::Module'); is($foo_role->name, 'FooRole', '... got the right name of FooRole'); is($foo_role->version, '0.01', '... got the right version of FooRole'); # methods ... ok($foo_role->has_method('foo'), '... FooRole has the foo method'); is($foo_role->get_method('foo')->body, \&FooRole::foo, '... FooRole got the foo method'); isa_ok($foo_role->get_method('foo'), 'Moose::Meta::Role::Method'); is_deeply( [ $foo_role->get_method_list() ], [ 'foo' ], '... got the right method list'); # attributes ... is_deeply( [ $foo_role->get_attribute_list() ], [], '... got the right attribute list'); ok(!$foo_role->has_attribute('bar'), '... FooRole does not have the bar attribute'); is( exception { $foo_role->add_attribute('bar' => (is => 'rw', isa => 'Foo')); }, undef, '... added the bar attribute okay' ); is_deeply( [ $foo_role->get_attribute_list() ], [ 'bar' ], '... got the right attribute list'); ok($foo_role->has_attribute('bar'), '... FooRole does have the bar attribute'); my $bar = $foo_role->get_attribute('bar'); is_deeply( $bar->original_options, { is => 'rw', isa => 'Foo' }, 'original options for bar attribute' ); my $bar_for_class = $bar->attribute_for_class('Moose::Meta::Attribute'); is( $bar_for_class->type_constraint, Moose::Util::TypeConstraints::class_type('Foo'), 'bar has a Foo class type' ); is( exception { $foo_role->add_attribute('baz' => (is => 'ro')); }, undef, '... added the baz attribute okay' ); is_deeply( [ sort $foo_role->get_attribute_list() ], [ 'bar', 'baz' ], '... got the right attribute list'); ok($foo_role->has_attribute('baz'), '... FooRole does have the baz attribute'); my $baz = $foo_role->get_attribute('baz'); is_deeply( $baz->original_options, { is => 'ro' }, 'original options for baz attribute' ); is( exception { $foo_role->remove_attribute('bar'); }, undef, '... removed the bar attribute okay' ); is_deeply( [ $foo_role->get_attribute_list() ], [ 'baz' ], '... got the right attribute list'); ok(!$foo_role->has_attribute('bar'), '... FooRole does not have the bar attribute'); ok($foo_role->has_attribute('baz'), '... FooRole does still have the baz attribute'); # method modifiers ok(!$foo_role->has_before_method_modifiers('boo'), '... no boo:before modifier'); my $method = sub { "FooRole::boo:before" }; is( exception { $foo_role->add_before_method_modifier('boo' => $method); }, undef, '... added a method modifier okay' ); ok($foo_role->has_before_method_modifiers('boo'), '... now we have a boo:before modifier'); is(($foo_role->get_before_method_modifiers('boo'))[0], $method, '... got the right method back'); is_deeply( [ $foo_role->get_method_modifier_list('before') ], [ 'boo' ], '... got the right list of before method modifiers'); done_testing; AttributeCore.xs100644000767000024 143112200352344 16115 0ustar00etherstaff000000000000Moose-2.1005/xs#include "mop.h" MODULE = Class::MOP::Mixin::AttributeCore PACKAGE = Class::MOP::Mixin::AttributeCore PROTOTYPES: DISABLE BOOT: INSTALL_SIMPLE_READER(Mixin::AttributeCore, name); INSTALL_SIMPLE_READER(Mixin::AttributeCore, accessor); INSTALL_SIMPLE_READER(Mixin::AttributeCore, reader); INSTALL_SIMPLE_READER(Mixin::AttributeCore, writer); INSTALL_SIMPLE_READER(Mixin::AttributeCore, predicate); INSTALL_SIMPLE_READER(Mixin::AttributeCore, clearer); INSTALL_SIMPLE_READER(Mixin::AttributeCore, builder); INSTALL_SIMPLE_READER(Mixin::AttributeCore, init_arg); INSTALL_SIMPLE_READER(Mixin::AttributeCore, initializer); INSTALL_SIMPLE_READER(Mixin::AttributeCore, definition_context); INSTALL_SIMPLE_READER(Mixin::AttributeCore, insertion_order); HasAttributes.xs100644000767000024 44112200352344 16103 0ustar00etherstaff000000000000Moose-2.1005/xs#include "mop.h" MODULE = Class::MOP::Mixin::HasAttributes PACKAGE = Class::MOP::Mixin::HasAttributes PROTOTYPES: DISABLE BOOT: INSTALL_SIMPLE_READER(Mixin::HasAttributes, attribute_metaclass); INSTALL_SIMPLE_READER_WITH_KEY(Mixin::HasAttributes, _attribute_map, attributes); Manual.pod100644000767000024 1722512200352344 16134 0ustar00etherstaff000000000000Moose-2.1005/lib/Moosepackage Moose::Manual; # ABSTRACT: What is Moose, and how do I use it? __END__ =pod =head1 NAME Moose::Manual - What is Moose, and how do I use it? =head1 VERSION version 2.1005 =head1 WHAT IS MOOSE? Moose is a I object system for Perl 5. Consider any modern object-oriented language (which Perl 5 definitely isn't). It provides keywords for attribute declaration, object construction, inheritance, and maybe more. These keywords are part of the language, and you don't care how they are implemented. Moose aims to do the same thing for Perl 5 OO. We can't actually create new keywords, but we do offer "sugar" that looks a lot like them. More importantly, with Moose, you I, without needing to know about blessed hashrefs, accessor methods, and so on. With Moose, you can concentrate on the I structure of your classes, focusing on "what" rather than "how". A class definition with Moose reads like a list of very concise English sentences. Moose is built on top of C, a meta-object protocol (aka MOP). Using the MOP, Moose provides complete introspection for all Moose-using classes. This means you can ask classes about their attributes, parents, children, methods, etc., all using a well-defined API. The MOP abstracts away the symbol table, looking at C<@ISA> vars, and all the other crufty Perl tricks we know and love(?). Moose is based in large part on the Perl 6 object system, as well as drawing on the best ideas from CLOS, Smalltalk, and many other languages. =head1 WHY MOOSE? Moose makes Perl 5 OO both simpler and more powerful. It encapsulates Perl 5 power tools in high-level declarative APIs which are easy to use. Best of all, you don't need to be a wizard to use it. But if you want to dig about in the guts, Moose lets you do that too, by using and extending its powerful introspection API. =head1 AN EXAMPLE package Person; use Moose; has 'first_name' => ( is => 'rw', isa => 'Str', ); has 'last_name' => ( is => 'rw', isa => 'Str', ); no Moose; __PACKAGE__->meta->make_immutable; This is a I class definition! package User; use DateTime; use Moose; extends 'Person'; has 'password' => ( is => 'rw', isa => 'Str', ); has 'last_login' => ( is => 'rw', isa => 'DateTime', handles => { 'date_of_last_login' => 'date' }, ); sub login { my $self = shift; my $pw = shift; return 0 if $pw ne $self->password; $self->last_login( DateTime->now() ); return 1; } no Moose; __PACKAGE__->meta->make_immutable; We'll leave the line-by-line explanation of this code to other documentation, but you can see how Moose reduces common OO idioms to simple declarative constructs. =head1 TABLE OF CONTENTS This manual consists of a number of documents. =over 4 =item L Introduces Moose concepts, and contrasts them against "old school" Perl 5 OO. =item L Shows two example classes, each written first with Moose and then with "plain old Perl 5". =item L How do you make use of Moose in your classes? Now that I'm a Moose, how do I subclass something? =item L Attributes are a core part of the Moose OO system. An attribute is a piece of data that an object has. Moose has a lot of attribute-related features! =item L Delegation is a powerful way to make use of attributes which are themselves objects. =item L Learn how objects are built in Moose, and in particular about the C and C methods. Also covers object destruction with C. =item L A method modifier lets you say "before calling method X, do this first", or "wrap method X in this code". Method modifiers are particularly handy in roles and with attribute accessors. =item L A role is something a class does (like "Debuggable" or "Printable"). Roles provide a way of adding behavior to classes that is orthogonal to inheritance. =item L Moose's type system lets you strictly define what values an attribute can contain. =item L Moose's meta API system lets you ask classes about their parents, children, methods, attributes, etc. =item L This document describes a few of the most useful Moose extensions on CPAN. =item L Moose has a lot of features, and there's definitely more than one way to do it. However, we think that picking a subset of these features and using them consistently makes everyone's life easier. =item L Frequently asked questions about Moose. =item L Interested in hacking on Moose? Read this. =item L This document details backwards-incompatibilities and other major changes to Moose. =back =head1 JUSTIFICATION If you're still asking yourself "Why do I need this?", then this section is for you. =over 4 =item Another object system!?!? Yes, we know there are many, many ways to build objects in Perl 5, many of them based on inside-out objects and other such things. Moose is different because it is not a new object system for Perl 5, but instead an extension of the existing object system. Moose is built on top of L, which is a metaclass system for Perl 5. This means that Moose not only makes building normal Perl 5 objects better, but it also provides the power of metaclass programming. =item Is this for real? Or is this just an experiment? Moose is I on the prototypes and experiments Stevan did for the Perl 6 meta-model. However, Moose is B an experiment or prototype; it is for B. =item Is this ready for use in production? Yes. Moose has been used successfully in production environments by many people and companies. There are Moose applications which have been in production with little or no issue now for years. We consider it highly stable and we are committed to keeping it stable. Of course, in the end, you need to make this call yourself. If you have any questions or concerns, please feel free to email Stevan or the moose@perl.org list, or just stop by irc.perl.org#moose and ask away. =item Is Moose just Perl 6 in Perl 5? No. While Moose is very much inspired by Perl 6, it is not itself Perl 6. Instead, it is an OO system for Perl 5. Stevan built Moose because he was tired of writing the same old boring Perl 5 OO code, and drooling over Perl 6 OO. So instead of switching to Ruby, he wrote Moose :) =item Wait, I modern, I thought it was just I? Stevan read Larry Wall's talk from the 1999 Linux World entitled "Perl, the first postmodern computer language" in which he talks about how he picked the features for Perl because he thought they were cool and he threw out the ones that he thought sucked. This got him thinking about how we have done the same thing in Moose. For Moose, we have "borrowed" features from Perl 6, CLOS (LISP), Smalltalk, Java, BETA, OCaml, Ruby and more, and the bits we didn't like (cause they sucked) we tossed aside. So for this reason (and a few others) Stevan has re-dubbed Moose a I object system. Nuff Said. =back =head1 AUTHOR Moose is maintained by the Moose Cabal, along with the help of many contributors. See L and L for details. =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2013 by Infinity Interactive, Inc.. This is free software; you can redistribute it and/or modify it under the same terms as the Perl 5 programming language system itself. =cut buildargs.t100644000767000024 155512200352344 16212 0ustar00etherstaff000000000000Moose-2.1005/t/basics#!/usr/bin/perl use strict; use warnings; use Test::More; { package Foo; use Moose; has bar => ( is => "rw" ); has baz => ( is => "rw" ); sub BUILDARGS { my ( $self, @args ) = @_; unshift @args, "bar" if @args % 2 == 1; return {@args}; } package Bar; use Moose; extends qw(Foo); } foreach my $class (qw(Foo Bar)) { is( $class->new->bar, undef, "no args" ); is( $class->new( bar => 42 )->bar, 42, "normal args" ); is( $class->new( 37 )->bar, 37, "single arg" ); { my $o = $class->new(bar => 42, baz => 47); is($o->bar, 42, '... got the right bar'); is($o->baz, 47, '... got the right bar'); } { my $o = $class->new(42, baz => 47); is($o->bar, 42, '... got the right bar'); is($o->baz, 47, '... got the right bar'); } } done_testing; bugs000755000767000024 012200352344 13377 5ustar00etherstaff000000000000Moose-2.1005/tDEMOLISHALL.t100644000767000024 202612200352344 15461 0ustar00etherstaff000000000000Moose-2.1005/t/bugs#!/usr/bin/env perl use strict; use warnings; use Test::More; my @called; do { package Class; use Moose; sub DEMOLISH { push @called, 'Class::DEMOLISH'; } sub DEMOLISHALL { my $self = shift; push @called, 'Class::DEMOLISHALL'; $self->SUPER::DEMOLISHALL(@_); } package Child; use Moose; extends 'Class'; sub DEMOLISH { push @called, 'Child::DEMOLISH'; } sub DEMOLISHALL { my $self = shift; push @called, 'Child::DEMOLISHALL'; $self->SUPER::DEMOLISHALL(@_); } }; is_deeply([splice @called], [], "no DEMOLISH calls yet"); do { my $object = Class->new; is_deeply([splice @called], [], "no DEMOLISH calls yet"); }; is_deeply([splice @called], ['Class::DEMOLISHALL', 'Class::DEMOLISH']); do { my $child = Child->new; is_deeply([splice @called], [], "no DEMOLISH calls yet"); }; is_deeply([splice @called], ['Child::DEMOLISHALL', 'Class::DEMOLISHALL', 'Child::DEMOLISH', 'Class::DEMOLISH']); done_testing; role_caller.t100644000767000024 123312200352344 16206 0ustar00etherstaff000000000000Moose-2.1005/t/bugspackage MyRole; use Moose::Role; sub foo { return (caller(0))[3] } no Moose::Role; package MyClass1; use Moose; with 'MyRole'; no Moose; package MyClass2; use Moose; with 'MyRole'; no Moose; package main; use Test::More; { local $TODO = 'Role composition does not clone methods yet'; is(MyClass1->foo, 'MyClass1::foo', 'method from role has correct name in caller()'); is(MyClass2->foo, 'MyClass2::foo', 'method from role has correct name in caller()'); } isnt(MyClass1->foo, "MyClass2::foo", "role method is not confused with other class" ); isnt(MyClass2->foo, "MyClass1::foo", "role method is not confused with other class" ); done_testing; meta_method.t100644000767000024 376412200352344 16222 0ustar00etherstaff000000000000Moose-2.1005/t/cmop#!/usr/bin/env perl use strict; use warnings; use Test::More; use Test::Fatal; use Class::MOP; { can_ok('Class::MOP::Class', 'meta'); isa_ok(Class::MOP::Class->meta->find_method_by_name('meta'), 'Class::MOP::Method::Meta'); { package Baz; use metaclass; } can_ok('Baz', 'meta'); isa_ok(Baz->meta->find_method_by_name('meta'), 'Class::MOP::Method::Meta'); my $meta = Class::MOP::Class->create('Quux'); can_ok('Quux', 'meta'); isa_ok(Quux->meta->find_method_by_name('meta'), 'Class::MOP::Method::Meta'); } { { package Blarg; use metaclass meta_name => 'blarg'; } ok(!Blarg->can('meta')); can_ok('Blarg', 'blarg'); isa_ok(Blarg->blarg->find_method_by_name('blarg'), 'Class::MOP::Method::Meta'); my $meta = Class::MOP::Class->create('Blorg', meta_name => 'blorg'); ok(!Blorg->can('meta')); can_ok('Blorg', 'blorg'); isa_ok(Blorg->blorg->find_method_by_name('blorg'), 'Class::MOP::Method::Meta'); } { { package Foo; use metaclass meta_name => undef; } my $meta = Class::MOP::class_of('Foo'); ok(!$meta->has_method('meta'), "no meta method was installed"); $meta->add_method(meta => sub { die 'META' }); is( exception { $meta->find_method_by_name('meta') }, undef, "can do meta-level stuff" ); is( exception { $meta->make_immutable }, undef, "can do meta-level stuff" ); is( exception { $meta->class_precedence_list }, undef, "can do meta-level stuff" ); } { my $meta = Class::MOP::Class->create('Bar', meta_name => undef); ok(!$meta->has_method('meta'), "no meta method was installed"); $meta->add_method(meta => sub { die 'META' }); is( exception { $meta->find_method_by_name('meta') }, undef, "can do meta-level stuff" ); is( exception { $meta->make_immutable }, undef, "can do meta-level stuff" ); is( exception { $meta->class_precedence_list }, undef, "can do meta-level stuff" ); } done_testing; Parent.pm100600000767000024 11112200352344 15776 0ustar00etherstaff000000000000Moose-2.1005/t/lib/Rolepackage Role::Parent; use Moose::Role; sub meth2 { } sub meth1 { } 1; apply_role.t100644000767000024 1462012200352344 16301 0ustar00etherstaff000000000000Moose-2.1005/t/roles#!/usr/bin/perl use strict; use warnings; use Test::More; use Test::Fatal; { package FooRole; use Moose::Role; our $VERSION = 23; has 'bar' => ( is => 'rw', isa => 'FooClass' ); has 'baz' => ( is => 'ro' ); sub goo {'FooRole::goo'} sub foo {'FooRole::foo'} override 'boo' => sub { 'FooRole::boo -> ' . super() }; around 'blau' => sub { my $c = shift; 'FooRole::blau -> ' . $c->(); }; } { package BarRole; use Moose::Role; sub woot {'BarRole::woot'} } { package BarClass; use Moose; sub boo {'BarClass::boo'} sub foo {'BarClass::foo'} # << the role overrides this ... } { package FooClass; use Moose; extends 'BarClass'; ::like( ::exception { with 'FooRole' => { -version => 42 } }, qr/FooRole version 42 required--this is only version 23/, 'applying role with unsatisfied version requirement' ); ::is( ::exception { with 'FooRole' => { -version => 13 } }, undef, 'applying role with satisfied version requirement' ); sub blau {'FooClass::blau'} # << the role wraps this ... sub goo {'FooClass::goo'} # << overrides the one from the role ... } { package FooBarClass; use Moose; extends 'FooClass'; with 'FooRole', 'BarRole'; } { package PlainJane; sub new { return bless {}, __PACKAGE__; } } my $foo_class_meta = FooClass->meta; isa_ok( $foo_class_meta, 'Moose::Meta::Class' ); my $foobar_class_meta = FooBarClass->meta; isa_ok( $foobar_class_meta, 'Moose::Meta::Class' ); isnt( exception { $foo_class_meta->does_role(); }, undef, '... does_role requires a role name' ); isnt( exception { $foo_class_meta->add_role(); }, undef, '... apply_role requires a role' ); isnt( exception { $foo_class_meta->add_role( bless( {} => 'Fail' ) ); }, undef, '... apply_role requires a role' ); ok( $foo_class_meta->does_role('FooRole'), '... the FooClass->meta does_role FooRole' ); ok( !$foo_class_meta->does_role('OtherRole'), '... the FooClass->meta !does_role OtherRole' ); ok( $foobar_class_meta->does_role('FooRole'), '... the FooBarClass->meta does_role FooRole' ); ok( $foobar_class_meta->does_role('BarRole'), '... the FooBarClass->meta does_role BarRole' ); ok( !$foobar_class_meta->does_role('OtherRole'), '... the FooBarClass->meta !does_role OtherRole' ); foreach my $method_name (qw(bar baz foo boo blau goo)) { ok( $foo_class_meta->has_method($method_name), '... FooClass has the method ' . $method_name ); ok( $foobar_class_meta->has_method($method_name), '... FooBarClass has the method ' . $method_name ); } ok( !$foo_class_meta->has_method('woot'), '... FooClass lacks the method woot' ); ok( $foobar_class_meta->has_method('woot'), '... FooBarClass has the method woot' ); foreach my $attr_name (qw(bar baz)) { ok( $foo_class_meta->has_attribute($attr_name), '... FooClass has the attribute ' . $attr_name ); ok( $foobar_class_meta->has_attribute($attr_name), '... FooBarClass has the attribute ' . $attr_name ); } can_ok( 'FooClass', 'does' ); ok( FooClass->does('FooRole'), '... the FooClass does FooRole' ); ok( !FooClass->does('BarRole'), '... the FooClass does not do BarRole' ); ok( !FooClass->does('OtherRole'), '... the FooClass does not do OtherRole' ); can_ok( 'FooBarClass', 'does' ); ok( FooBarClass->does('FooRole'), '... the FooClass does FooRole' ); ok( FooBarClass->does('BarRole'), '... the FooBarClass does FooBarRole' ); ok( !FooBarClass->does('OtherRole'), '... the FooBarClass does not do OtherRole' ); my $foo = FooClass->new(); isa_ok( $foo, 'FooClass' ); my $foobar = FooBarClass->new(); isa_ok( $foobar, 'FooBarClass' ); is( $foo->goo, 'FooClass::goo', '... got the right value of goo' ); is( $foobar->goo, 'FooRole::goo', '... got the right value of goo' ); is( $foo->boo, 'FooRole::boo -> BarClass::boo', '... got the right value from ->boo' ); is( $foobar->boo, 'FooRole::boo -> FooRole::boo -> BarClass::boo', '... got the right value from ->boo (double wrapped)' ); is( $foo->blau, 'FooRole::blau -> FooClass::blau', '... got the right value from ->blau' ); is( $foobar->blau, 'FooRole::blau -> FooRole::blau -> FooClass::blau', '... got the right value from ->blau' ); foreach my $foo ( $foo, $foobar ) { can_ok( $foo, 'does' ); ok( $foo->does('FooRole'), '... an instance of FooClass does FooRole' ); ok( !$foo->does('OtherRole'), '... and instance of FooClass does not do OtherRole' ); can_ok( $foobar, 'does' ); ok( $foobar->does('FooRole'), '... an instance of FooBarClass does FooRole' ); ok( $foobar->does('BarRole'), '... an instance of FooBarClass does BarRole' ); ok( !$foobar->does('OtherRole'), '... and instance of FooBarClass does not do OtherRole' ); for my $method (qw/bar baz foo boo goo blau/) { can_ok( $foo, $method ); } is( $foo->foo, 'FooRole::foo', '... got the right value of foo' ); ok( !defined( $foo->baz ), '... $foo->baz is undefined' ); ok( !defined( $foo->bar ), '... $foo->bar is undefined' ); isnt( exception { $foo->baz(1); }, undef, '... baz is a read-only accessor' ); isnt( exception { $foo->bar(1); }, undef, '... bar is a read-write accessor with a type constraint' ); my $foo2 = FooClass->new(); isa_ok( $foo2, 'FooClass' ); is( exception { $foo->bar($foo2); }, undef, '... bar is a read-write accessor with a type constraint' ); is( $foo->bar, $foo2, '... got the right value for bar now' ); } { { package MRole; use Moose::Role; sub meth { } } { package MRole2; use Moose::Role; sub meth2 { } } { use Moose::Meta::Class; use Moose::Object; use Moose::Util qw(apply_all_roles); my $class = Moose::Meta::Class->create( 'Class' => ( superclasses => [ 'Moose::Object' ], )); apply_all_roles($class, MRole->meta, MRole2->meta); ok(Class->can('meth'), "can meth"); ok(Class->can('meth2'), "can meth2"); } } { ok(!Moose::Util::find_meta('PlainJane'), 'not initialized'); Moose::Util::apply_all_roles('PlainJane', 'BarRole'); ok(Moose::Util::find_meta('PlainJane'), 'initialized'); ok(Moose::Util::find_meta('PlainJane')->does_role('BarRole'), 'does BarRole'); my $pj = PlainJane->new(); ok($pj->can('woot'), 'can woot'); } done_testing; overriding.t100644000767000024 1273112200352344 16304 0ustar00etherstaff000000000000Moose-2.1005/t/roles#!/usr/bin/perl use strict; use warnings; use Test::More; use Test::Fatal; { # test no conflicts here package Role::A; use Moose::Role; sub bar { 'Role::A::bar' } package Role::B; use Moose::Role; sub xxy { 'Role::B::xxy' } package Role::C; use Moose::Role; ::is( ::exception { with qw(Role::A Role::B); # no conflict here }, undef, "define role C" ); sub foo { 'Role::C::foo' } sub zot { 'Role::C::zot' } package Class::A; use Moose; ::is( ::exception { with qw(Role::C); }, undef, "define class A" ); sub zot { 'Class::A::zot' } } can_ok( Class::A->new, qw(foo bar xxy zot) ); is( Class::A->new->foo, "Role::C::foo", "... got the right foo method" ); is( Class::A->new->zot, "Class::A::zot", "... got the right zot method" ); is( Class::A->new->bar, "Role::A::bar", "... got the right bar method" ); is( Class::A->new->xxy, "Role::B::xxy", "... got the right xxy method" ); { # check that when a role is added to another role # that the consumer's method shadows just like for classes. package Role::A::Shadow; use Moose::Role; with 'Role::A'; sub bar { 'Role::A::Shadow::bar' } package Class::A::Shadow; use Moose; ::is( ::exception { with 'Role::A::Shadow'; }, undef, '... did fufill the requirement of &bar method' ); } can_ok( Class::A::Shadow->new, qw(bar) ); is( Class::A::Shadow->new->bar, 'Role::A::Shadow::bar', "... got the right bar method" ); { # check that when two roles are composed, they conflict # but the composing role can resolve that conflict package Role::D; use Moose::Role; sub foo { 'Role::D::foo' } sub bar { 'Role::D::bar' } package Role::E; use Moose::Role; sub foo { 'Role::E::foo' } sub xxy { 'Role::E::xxy' } package Role::F; use Moose::Role; ::is( ::exception { with qw(Role::D Role::E); # conflict between 'foo's here }, undef, "define role Role::F" ); sub foo { 'Role::F::foo' } sub zot { 'Role::F::zot' } package Class::B; use Moose; ::is( ::exception { with qw(Role::F); }, undef, "define class Class::B" ); sub zot { 'Class::B::zot' } } can_ok( Class::B->new, qw(foo bar xxy zot) ); is( Class::B->new->foo, "Role::F::foo", "... got the &foo method okay" ); is( Class::B->new->zot, "Class::B::zot", "... got the &zot method okay" ); is( Class::B->new->bar, "Role::D::bar", "... got the &bar method okay" ); is( Class::B->new->xxy, "Role::E::xxy", "... got the &xxy method okay" ); ok(!Role::F->meta->requires_method('foo'), '... Role::F fufilled the &foo requirement'); { # check that a conflict can be resolved # by a role, but also new ones can be # created just as easily ... package Role::D::And::E::NoConflict; use Moose::Role; ::is( ::exception { with qw(Role::D Role::E); # conflict between 'foo's here }, undef, "... define role Role::D::And::E::NoConflict" ); sub foo { 'Role::D::And::E::NoConflict::foo' } # this overrides ... sub xxy { 'Role::D::And::E::NoConflict::xxy' } # and so do these ... sub bar { 'Role::D::And::E::NoConflict::bar' } } ok(!Role::D::And::E::NoConflict->meta->requires_method('foo'), '... Role::D::And::E::NoConflict fufilled the &foo requirement'); ok(!Role::D::And::E::NoConflict->meta->requires_method('xxy'), '... Role::D::And::E::NoConflict fulfilled the &xxy requirement'); ok(!Role::D::And::E::NoConflict->meta->requires_method('bar'), '... Role::D::And::E::NoConflict fulfilled the &bar requirement'); { # conflict propagation package Role::H; use Moose::Role; sub foo { 'Role::H::foo' } sub bar { 'Role::H::bar' } package Role::J; use Moose::Role; sub foo { 'Role::J::foo' } sub xxy { 'Role::J::xxy' } package Role::I; use Moose::Role; ::is( ::exception { with qw(Role::J Role::H); # conflict between 'foo's here }, undef, "define role Role::I" ); sub zot { 'Role::I::zot' } sub zzy { 'Role::I::zzy' } package Class::C; use Moose; ::like( ::exception { with qw(Role::I); }, qr/Due to a method name conflict in roles 'Role::H' and 'Role::J', the method 'foo' must be implemented or excluded by 'Class::C'/, "defining class Class::C fails" ); sub zot { 'Class::C::zot' } package Class::E; use Moose; ::is( ::exception { with qw(Role::I); }, undef, "resolved with method" ); sub foo { 'Class::E::foo' } sub zot { 'Class::E::zot' } } can_ok( Class::E->new, qw(foo bar xxy zot) ); is( Class::E->new->foo, "Class::E::foo", "... got the right &foo method" ); is( Class::E->new->zot, "Class::E::zot", "... got the right &zot method" ); is( Class::E->new->bar, "Role::H::bar", "... got the right &bar method" ); is( Class::E->new->xxy, "Role::J::xxy", "... got the right &xxy method" ); ok(Role::I->meta->requires_method('foo'), '... Role::I still have the &foo requirement'); { is( exception { package Class::D; use Moose; has foo => ( default => __PACKAGE__ . "::foo", is => "rw" ); sub zot { 'Class::D::zot' } with qw(Role::I); }, undef, "resolved with attr" ); can_ok( Class::D->new, qw(foo bar xxy zot) ); is( eval { Class::D->new->bar }, "Role::H::bar", "bar" ); is( eval { Class::D->new->zzy }, "Role::I::zzy", "zzy" ); is( eval { Class::D->new->foo }, "Class::D::foo", "foo" ); is( eval { Class::D->new->zot }, "Class::D::zot", "zot" ); } done_testing; role_attrs.t100644000767000024 242212200352344 16266 0ustar00etherstaff000000000000Moose-2.1005/t/rolesuse strict; use warnings; use Test::More; use Moose (); use Moose::Meta::Role; use Moose::Util; my $role1 = Moose::Meta::Role->initialize('Foo'); $role1->add_attribute( foo => ( is => 'ro' ) ); ok( $role1->has_attribute('foo'), 'Foo role has a foo attribute' ); my $foo_attr = $role1->get_attribute('foo'); is( $foo_attr->associated_role->name, 'Foo', 'associated_role for foo attr is Foo role' ); isa_ok( $foo_attr->attribute_for_class('Moose::Meta::Attribute'), 'Moose::Meta::Attribute', 'attribute returned by ->attribute_for_class' ); my $role2 = Moose::Meta::Role->initialize('Bar'); $role1->apply($role2); ok( $role2->has_attribute('foo'), 'Bar role has a foo attribute' ); is( $foo_attr->associated_role->name, 'Foo', 'associated_role for foo attr is still Foo role' ); isa_ok( $foo_attr->attribute_for_class('Moose::Meta::Attribute'), 'Moose::Meta::Attribute', 'attribute returned by ->attribute_for_class' ); my $role3 = Moose::Meta::Role->initialize('Baz'); my $combined = Moose::Meta::Role->combine( [ $role1->name ], [ $role3->name ] ); ok( $combined->has_attribute('foo'), 'combined role has a foo attribute' ); is( $foo_attr->associated_role->name, 'Foo', 'associated_role for foo attr is still Foo role' ); done_testing; no-tabs.t100644000767000024 21212200352344 16112 0ustar00etherstaff000000000000Moose-2.1005/xt/releaseuse strict; use warnings; use Test::More; eval 'use Test::NoTabs'; plan skip_all => 'Test::NoTabs required' if $@; all_perl_files_ok(); Exporter.pm100644000767000024 7066412200352344 16367 0ustar00etherstaff000000000000Moose-2.1005/lib/Moosepackage Moose::Exporter; BEGIN { $Moose::Exporter::AUTHORITY = 'cpan:STEVAN'; } { $Moose::Exporter::VERSION = '2.1005'; } use strict; use warnings; use Class::Load qw(is_class_loaded); use Class::MOP; use List::MoreUtils qw( first_index uniq ); use Moose::Util::MetaRole; use Scalar::Util qw(reftype); use Sub::Exporter 0.980; use Sub::Name qw(subname); my %EXPORT_SPEC; sub setup_import_methods { my ( $class, %args ) = @_; $args{exporting_package} ||= caller(); $class->build_import_methods( %args, install => [qw(import unimport init_meta)] ); } # A reminder to intrepid Moose hackers # there may be more than one level of exporter # don't make doy cry. -- perigrin sub build_import_methods { my ( $class, %args ) = @_; my $exporting_package = $args{exporting_package} ||= caller(); my $meta_lookup = $args{meta_lookup} || sub { Class::MOP::class_of(shift) }; $EXPORT_SPEC{$exporting_package} = \%args; my @exports_from = $class->_follow_also($exporting_package); my $export_recorder = {}; my $is_reexport = {}; my $exports = $class->_make_sub_exporter_params( [ $exporting_package, @exports_from ], $export_recorder, $is_reexport, $args{meta_lookup}, # so that we don't pass through the default ); my $exporter = $class->_make_exporter( $exports, $is_reexport, $meta_lookup, ); my %methods; $methods{import} = $class->_make_import_sub( $exporting_package, $exporter, \@exports_from, $is_reexport, $meta_lookup, ); $methods{unimport} = $class->_make_unimport_sub( $exporting_package, $exports, $export_recorder, $is_reexport, $meta_lookup, ); $methods{init_meta} = $class->_make_init_meta( $exporting_package, \%args, $meta_lookup, ); my $package = Class::MOP::Package->initialize($exporting_package); for my $to_install ( @{ $args{install} || [] } ) { my $symbol = '&' . $to_install; next unless $methods{$to_install} && !$package->has_package_symbol($symbol); $package->add_package_symbol( $symbol, $methods{$to_install} ); } return ( $methods{import}, $methods{unimport}, $methods{init_meta} ); } sub _make_exporter { my ($class, $exports, $is_reexport, $meta_lookup) = @_; return Sub::Exporter::build_exporter( { exports => $exports, groups => { default => [':all'] }, installer => sub { my ($arg, $to_export) = @_; my $meta = $meta_lookup->($arg->{into}); goto &Sub::Exporter::default_installer unless $meta; # don't overwrite existing symbols with our magically flagged # version of it if we would install the same sub that's already # in the importer my @filtered_to_export; my %installed; for (my $i = 0; $i < @{ $to_export }; $i += 2) { my ($as, $cv) = @{ $to_export }[$i, $i + 1]; next if !ref($as) && $meta->has_package_symbol('&' . $as) && $meta->get_package_symbol('&' . $as) == $cv; push @filtered_to_export, $as, $cv; $installed{$as} = 1 unless ref $as; } Sub::Exporter::default_installer($arg, \@filtered_to_export); for my $name ( keys %{$is_reexport} ) { no strict 'refs'; no warnings 'once'; next unless exists $installed{$name}; _flag_as_reexport( \*{ join q{::}, $arg->{into}, $name } ); } }, } ); } sub _follow_also { my $class = shift; my $exporting_package = shift; _die_if_cycle_found_in_also_list_for_package($exporting_package); return uniq( _follow_also_real($exporting_package) ); } sub _follow_also_real { my $exporting_package = shift; my @also = _also_list_for_package($exporting_package); return map { $_, _follow_also_real($_) } @also; } sub _also_list_for_package { my $package = shift; if ( !exists $EXPORT_SPEC{$package} ) { my $loaded = is_class_loaded($package); die "Package in also ($package) does not seem to " . "use Moose::Exporter" . ( $loaded ? "" : " (is it loaded?)" ); } my $also = $EXPORT_SPEC{$package}{also}; return unless defined $also; return ref $also ? @$also : $also; } # this is no Tarjan algorithm, but for the list sizes expected, # brute force will probably be fine (and more maintainable) sub _die_if_cycle_found_in_also_list_for_package { my $package = shift; _die_if_also_list_cycles_back_to_existing_stack( [ _also_list_for_package($package) ], [$package], ); } sub _die_if_also_list_cycles_back_to_existing_stack { my ( $also_list, $existing_stack ) = @_; return unless @$also_list && @$existing_stack; for my $also_member (@$also_list) { for my $stack_member (@$existing_stack) { next unless $also_member eq $stack_member; die "Circular reference in 'also' parameter to Moose::Exporter between " . join( ', ', @$existing_stack ) . " and $also_member"; } _die_if_also_list_cycles_back_to_existing_stack( [ _also_list_for_package($also_member) ], [ $also_member, @$existing_stack ], ); } } sub _parse_trait_aliases { my $class = shift; my ($package, $aliases) = @_; my @ret; for my $alias (@$aliases) { my $name; if (ref($alias)) { reftype($alias) eq 'ARRAY' or Moose->throw_error(reftype($alias) . " references are not " . "valid arguments to the 'trait_aliases' " . "option"); ($alias, $name) = @$alias; } else { ($name = $alias) =~ s/.*:://; } push @ret, subname "${package}::${name}" => sub () { $alias }; } return @ret; } sub _make_sub_exporter_params { my $class = shift; my $packages = shift; my $export_recorder = shift; my $is_reexport = shift; my $meta_lookup_override = shift; my %exports; my $current_meta_lookup; for my $package ( @{$packages} ) { my $args = $EXPORT_SPEC{$package} or die "The $package package does not use Moose::Exporter\n"; $current_meta_lookup = $meta_lookup_override || $args->{meta_lookup}; $meta_lookup_override = $current_meta_lookup; my $meta_lookup = $current_meta_lookup || sub { Class::MOP::class_of(shift) }; for my $name ( @{ $args->{with_meta} } ) { my $sub = $class->_sub_from_package( $package, $name ) or next; my $fq_name = $package . '::' . $name; $exports{$name} = $class->_make_wrapped_sub_with_meta( $fq_name, $sub, $export_recorder, $meta_lookup, ) unless exists $exports{$name}; } for my $name ( @{ $args->{with_caller} } ) { my $sub = $class->_sub_from_package( $package, $name ) or next; my $fq_name = $package . '::' . $name; $exports{$name} = $class->_make_wrapped_sub( $fq_name, $sub, $export_recorder, ) unless exists $exports{$name}; } my @extra_exports = $class->_parse_trait_aliases( $package, $args->{trait_aliases}, ); for my $name ( @{ $args->{as_is} }, @extra_exports ) { my ( $sub, $coderef_name ); if ( ref $name ) { $sub = $name; my $coderef_pkg; ( $coderef_pkg, $coderef_name ) = Class::MOP::get_code_info($name); if ( $coderef_pkg ne $package ) { $is_reexport->{$coderef_name} = 1; } } else { $sub = $class->_sub_from_package( $package, $name ) or next; $coderef_name = $name; } $export_recorder->{$sub} = 1; $exports{$coderef_name} = sub { $sub } unless exists $exports{$coderef_name}; } } return \%exports; } sub _sub_from_package { my $sclass = shift; my $package = shift; my $name = shift; my $sub = do { no strict 'refs'; \&{ $package . '::' . $name }; }; return $sub if defined &$sub; Carp::cluck "Trying to export undefined sub ${package}::${name}"; return; } our $CALLER; sub _make_wrapped_sub { my $self = shift; my $fq_name = shift; my $sub = shift; my $export_recorder = shift; # We need to set the package at import time, so that when # package Foo imports has(), we capture "Foo" as the # package. This lets other packages call Foo::has() and get # the right package. This is done for backwards compatibility # with existing production code, not because this is a good # idea ;) return sub { my $caller = $CALLER; my $wrapper = $self->_curry_wrapper( $sub, $fq_name, $caller ); my $sub = subname( $fq_name => $wrapper ); $export_recorder->{$sub} = 1; return $sub; }; } sub _make_wrapped_sub_with_meta { my $self = shift; my $fq_name = shift; my $sub = shift; my $export_recorder = shift; my $meta_lookup = shift; return sub { my $caller = $CALLER; my $wrapper = $self->_late_curry_wrapper( $sub, $fq_name, $meta_lookup => $caller ); my $sub = subname( $fq_name => $wrapper ); $export_recorder->{$sub} = 1; return $sub; }; } sub _curry_wrapper { my $class = shift; my $sub = shift; my $fq_name = shift; my @extra = @_; my $wrapper = sub { $sub->( @extra, @_ ) }; if ( my $proto = prototype $sub ) { # XXX - Perl's prototype sucks. Use & to make set_prototype # ignore the fact that we're passing "private variables" &Scalar::Util::set_prototype( $wrapper, $proto ); } return $wrapper; } sub _late_curry_wrapper { my $class = shift; my $sub = shift; my $fq_name = shift; my $extra = shift; my @ex_args = @_; my $wrapper = sub { # resolve curried arguments at runtime via this closure my @curry = ( $extra->(@ex_args) ); return $sub->( @curry, @_ ); }; if ( my $proto = prototype $sub ) { # XXX - Perl's prototype sucks. Use & to make set_prototype # ignore the fact that we're passing "private variables" &Scalar::Util::set_prototype( $wrapper, $proto ); } return $wrapper; } sub _make_import_sub { shift; my $exporting_package = shift; my $exporter = shift; my $exports_from = shift; my $is_reexport = shift; my $meta_lookup = shift; return sub { # I think we could use Sub::Exporter's collector feature # to do this, but that would be rather gross, since that # feature isn't really designed to return a value to the # caller of the exporter sub. # # Also, this makes sure we preserve backwards compat for # _get_caller, so it always sees the arguments in the # expected order. my $traits; ( $traits, @_ ) = _strip_traits(@_); my $metaclass; ( $metaclass, @_ ) = _strip_metaclass(@_); $metaclass = Moose::Util::resolve_metaclass_alias( 'Class' => $metaclass ) if defined $metaclass && length $metaclass; my $meta_name; ( $meta_name, @_ ) = _strip_meta_name(@_); # Normally we could look at $_[0], but in some weird cases # (involving goto &Moose::import), $_[0] ends as something # else (like Squirrel). my $class = $exporting_package; $CALLER = _get_caller(@_); # this works because both pragmas set $^H (see perldoc # perlvar) which affects the current compilation - # i.e. the file who use'd us - which is why we don't need # to do anything special to make it affect that file # rather than this one (which is already compiled) strict->import; warnings->import; my $did_init_meta; for my $c ( grep { $_->can('init_meta') } $class, @{$exports_from} ) { # init_meta can apply a role, which when loaded uses # Moose::Exporter, which in turn sets $CALLER, so we need # to protect against that. local $CALLER = $CALLER; $c->init_meta( for_class => $CALLER, metaclass => $metaclass, meta_name => $meta_name, ); $did_init_meta = 1; } { # The metaroles will use Moose::Role, which in turn uses # Moose::Exporter, which in turn sets $CALLER, so we need # to protect against that. local $CALLER = $CALLER; _apply_metaroles( $CALLER, [$class, @$exports_from], $meta_lookup ); } if ( $did_init_meta && @{$traits} ) { # The traits will use Moose::Role, which in turn uses # Moose::Exporter, which in turn sets $CALLER, so we need # to protect against that. local $CALLER = $CALLER; _apply_meta_traits( $CALLER, $traits, $meta_lookup ); } elsif ( @{$traits} ) { require Moose; Moose->throw_error( "Cannot provide traits when $class does not have an init_meta() method" ); } my ( undef, @args ) = @_; my $extra = shift @args if ref $args[0] eq 'HASH'; $extra ||= {}; if ( !$extra->{into} ) { $extra->{into_level} ||= 0; $extra->{into_level}++; } $class->$exporter( $extra, @args ); }; } sub _strip_traits { my $idx = first_index { ( $_ || '' ) eq '-traits' } @_; return ( [], @_ ) unless $idx >= 0 && $#_ >= $idx + 1; my $traits = $_[ $idx + 1 ]; splice @_, $idx, 2; $traits = [$traits] unless ref $traits; return ( $traits, @_ ); } sub _strip_metaclass { my $idx = first_index { ( $_ || '' ) eq '-metaclass' } @_; return ( undef, @_ ) unless $idx >= 0 && $#_ >= $idx + 1; my $metaclass = $_[ $idx + 1 ]; splice @_, $idx, 2; return ( $metaclass, @_ ); } sub _strip_meta_name { my $idx = first_index { ( $_ || '' ) eq '-meta_name' } @_; return ( 'meta', @_ ) unless $idx >= 0 && $#_ >= $idx + 1; my $meta_name = $_[ $idx + 1 ]; splice @_, $idx, 2; return ( $meta_name, @_ ); } sub _apply_metaroles { my ($class, $exports_from, $meta_lookup) = @_; my $metaroles = _collect_metaroles($exports_from); my $base_class_roles = delete $metaroles->{base_class_roles}; my $meta = $meta_lookup->($class); # for instance, Moose.pm uses Moose::Util::TypeConstraints return unless $meta; Moose::Util::MetaRole::apply_metaroles( for => $meta, %$metaroles, ) if keys %$metaroles; Moose::Util::MetaRole::apply_base_class_roles( for => $meta, roles => $base_class_roles, ) if $meta->isa('Class::MOP::Class') && $base_class_roles && @$base_class_roles; } sub _collect_metaroles { my ($exports_from) = @_; my @old_style_role_types = map { "${_}_roles" } qw( metaclass attribute_metaclass method_metaclass wrapped_method_metaclass instance_metaclass constructor_class destructor_class error_class ); my %class_metaroles; my %role_metaroles; my @base_class_roles; my %old_style_roles; for my $exporter (@$exports_from) { my $data = $EXPORT_SPEC{$exporter}; if (exists $data->{class_metaroles}) { for my $type (keys %{ $data->{class_metaroles} }) { push @{ $class_metaroles{$type} ||= [] }, @{ $data->{class_metaroles}{$type} }; } } if (exists $data->{role_metaroles}) { for my $type (keys %{ $data->{role_metaroles} }) { push @{ $role_metaroles{$type} ||= [] }, @{ $data->{role_metaroles}{$type} }; } } if (exists $data->{base_class_roles}) { push @base_class_roles, @{ $data->{base_class_roles} }; } for my $type (@old_style_role_types) { if (exists $data->{$type}) { push @{ $old_style_roles{$type} ||= [] }, @{ $data->{$type} }; } } } return { (keys(%class_metaroles) ? (class_metaroles => \%class_metaroles) : ()), (keys(%role_metaroles) ? (role_metaroles => \%role_metaroles) : ()), (@base_class_roles ? (base_class_roles => \@base_class_roles) : ()), %old_style_roles, }; } sub _apply_meta_traits { my ( $class, $traits, $meta_lookup ) = @_; return unless @{$traits}; my $meta = $meta_lookup->($class); my $type = $meta->isa('Moose::Meta::Role') ? 'Role' : $meta->isa('Class::MOP::Class') ? 'Class' : Moose->throw_error('Cannot determine metaclass type for ' . 'trait application. Meta isa ' . ref $meta); my @resolved_traits = map { ref $_ ? $_ : Moose::Util::resolve_metatrait_alias( $type => $_ ) } @$traits; return unless @resolved_traits; my %args = ( for => $class ); if ( $meta->isa('Moose::Meta::Role') ) { $args{role_metaroles} = { role => \@resolved_traits }; } else { $args{class_metaroles} = { class => \@resolved_traits }; } Moose::Util::MetaRole::apply_metaroles(%args); } sub _get_caller { # 1 extra level because it's called by import so there's a layer # of indirection my $offset = 1; return ( ref $_[1] && defined $_[1]->{into} ) ? $_[1]->{into} : ( ref $_[1] && defined $_[1]->{into_level} ) ? caller( $offset + $_[1]->{into_level} ) : caller($offset); } sub _make_unimport_sub { shift; my $exporting_package = shift; my $exports = shift; my $export_recorder = shift; my $is_reexport = shift; my $meta_lookup = shift; return sub { my $caller = scalar caller(); Moose::Exporter->_remove_keywords( $caller, [ keys %{$exports} ], $export_recorder, $is_reexport, ); }; } sub _remove_keywords { shift; my $package = shift; my $keywords = shift; my $recorded_exports = shift; my $is_reexport = shift; no strict 'refs'; foreach my $name ( @{$keywords} ) { if ( defined &{ $package . '::' . $name } ) { my $sub = \&{ $package . '::' . $name }; # make sure it is from us next unless $recorded_exports->{$sub}; if ( $is_reexport->{$name} ) { no strict 'refs'; next unless _export_is_flagged( \*{ join q{::} => $package, $name } ); } # and if it is from us, then undef the slot delete ${ $package . '::' }{$name}; } } } # maintain this for now for backcompat # make sure to return a sub to install in the same circumstances as previously # but this functionality now happens at the end of ->import sub _make_init_meta { shift; my $class = shift; my $args = shift; my $meta_lookup = shift; my %old_style_roles; for my $role ( map {"${_}_roles"} qw( metaclass attribute_metaclass method_metaclass wrapped_method_metaclass instance_metaclass constructor_class destructor_class error_class ) ) { $old_style_roles{$role} = $args->{$role} if exists $args->{$role}; } my %base_class_roles; %base_class_roles = ( roles => $args->{base_class_roles} ) if exists $args->{base_class_roles}; my %new_style_roles = map { $_ => $args->{$_} } grep { exists $args->{$_} } qw( class_metaroles role_metaroles ); return unless %new_style_roles || %old_style_roles || %base_class_roles; return sub { shift; my %opts = @_; $meta_lookup->($opts{for_class}); }; } sub import { strict->import; warnings->import; } 1; # ABSTRACT: make an import() and unimport() just like Moose.pm __END__ =pod =head1 NAME Moose::Exporter - make an import() and unimport() just like Moose.pm =head1 VERSION version 2.1005 =head1 SYNOPSIS package MyApp::Moose; use Moose (); use Moose::Exporter; Moose::Exporter->setup_import_methods( with_meta => [ 'has_rw', 'sugar2' ], as_is => [ 'sugar3', \&Some::Random::thing ], also => 'Moose', ); sub has_rw { my ( $meta, $name, %options ) = @_; $meta->add_attribute( $name, is => 'rw', %options, ); } # then later ... package MyApp::User; use MyApp::Moose; has 'name'; has_rw 'size'; thing; no MyApp::Moose; =head1 DESCRIPTION This module encapsulates the exporting of sugar functions in a C-like manner. It does this by building custom C and C methods for your module, based on a spec you provide. It also lets you "stack" Moose-alike modules so you can export Moose's sugar as well as your own, along with sugar from any random C module, as long as they all use C. This feature exists to let you bundle a set of MooseX modules into a policy module that developers can use directly instead of using Moose itself. To simplify writing exporter modules, C also imports C and C into your exporter module, as well as into modules that use it. =head1 METHODS This module provides two public methods: =over 4 =item B<< Moose::Exporter->setup_import_methods(...) >> When you call this method, C builds custom C and C methods for your module. The C method will export the functions you specify, and can also re-export functions exported by some other module (like C). If you pass any parameters for L, the C method will also call C and C as needed, after making sure the metaclass is initialized. The C method cleans the caller's namespace of all the exported functions. This includes any functions you re-export from other packages. However, if the consumer of your package also imports those functions from the original package, they will I be cleaned. Note that if any of these methods already exist, they will not be overridden, you will have to use C to get the coderef that would be installed. This method accepts the following parameters: =over 8 =item * with_meta => [ ... ] This list of function I will be wrapped and then exported. The wrapper will pass the metaclass object for the caller as its first argument. Many sugar functions will need to use this metaclass object to do something to the calling package. =item * as_is => [ ... ] This list of function names or sub references will be exported as-is. You can identify a subroutine by reference, which is handy to re-export some other module's functions directly by reference (C<\&Some::Package::function>). If you do export some other package's function, this function will never be removed by the C method. The reason for this is we cannot know if the caller I explicitly imported the sub themselves, and therefore wants to keep it. =item * trait_aliases => [ ... ] This is a list of package names which should have shortened aliases exported, similar to the functionality of L. Each element in the list can be either a package name, in which case the export will be named as the last namespace component of the package, or an arrayref, whose first element is the package to alias to, and second element is the alias to export. =item * also => $name or \@names This is a list of modules which contain functions that the caller wants to export. These modules must also use C. The most common use case will be to export the functions from C. Functions specified by C or C take precedence over functions exported by modules specified by C, so that a module can selectively override functions exported by another module. C also makes sure all these functions get removed when C is called. =item * meta_lookup => sub { ... } This is a function which will be called to provide the metaclass to be operated upon by the exporter. This is an advanced feature intended for use by package generator modules in the vein of L in order to simplify reusing sugar from other modules that use C. This function is used, for example, to select the metaclass to bind to functions that are exported using the C option. This function will receive one parameter: the class name into which the sugar is being exported. The default implementation is: sub { Class::MOP::class_of(shift) } Accordingly, this function is expected to return a metaclass. =back You can also provide parameters for C and C. Specifically, valid parameters are "class_metaroles", "role_metaroles", and "base_class_roles". =item B<< Moose::Exporter->build_import_methods(...) >> Returns two code refs, one for C and one for C. Accepts the additional C option, which accepts an arrayref of method names to install into your exporting package. The valid options are C and C. Calling C is equivalent to calling C with C<< install => [qw(import unimport)] >> except that it doesn't also return the methods. The C method is built using L. This means that it can take a hashref of the form C<< { into => $package } >> to specify the package it operates on. Used by C. =back =head1 IMPORTING AND init_meta If you want to set an alternative base object class or metaclass class, see above for details on how this module can call L for you. If you want to do something that is not supported by this module, simply define an C method in your class. The C method that C generates for you will call this method (if it exists). It will always pass the caller to this method via the C parameter. Most of the time, your C method will probably just call C<< Moose->init_meta >> to do the real work: sub init_meta { shift; # our class name return Moose->init_meta( @_, metaclass => 'My::Metaclass' ); } =head1 METACLASS TRAITS The C method generated by C will allow the user of your module to specify metaclass traits in a C<-traits> parameter passed as part of the import: use Moose -traits => 'My::Meta::Trait'; use Moose -traits => [ 'My::Meta::Trait', 'My::Other::Trait' ]; These traits will be applied to the caller's metaclass instance. Providing traits for an exporting class that does not create a metaclass for the caller is an error. =head1 BUGS See L for details on reporting bugs. =head1 AUTHOR Moose is maintained by the Moose Cabal, along with the help of many contributors. See L and L for details. =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2013 by Infinity Interactive, Inc.. This is free software; you can redistribute it and/or modify it under the same terms as the Perl 5 programming language system itself. =cut create_class.t100644000767000024 560212200352344 16355 0ustar00etherstaff000000000000Moose-2.1005/t/cmopuse strict; use warnings; use Test::More; use Test::Fatal; use Class::MOP; my $Point = Class::MOP::Class->create('Point' => ( version => '0.01', attributes => [ Class::MOP::Attribute->new('x' => ( reader => 'x', init_arg => 'x' )), Class::MOP::Attribute->new('y' => ( accessor => 'y', init_arg => 'y' )), ], methods => { 'new' => sub { my $class = shift; my $instance = $class->meta->new_object(@_); bless $instance => $class; }, 'clear' => sub { my $self = shift; $self->{'x'} = 0; $self->{'y'} = 0; } } )); my $Point3D = Class::MOP::Class->create('Point3D' => ( version => '0.01', superclasses => [ 'Point' ], attributes => [ Class::MOP::Attribute->new('z' => ( default => 123 )), ], methods => { 'clear' => sub { my $self = shift; $self->{'z'} = 0; $self->SUPER::clear(); } } )); isa_ok($Point, 'Class::MOP::Class'); isa_ok($Point3D, 'Class::MOP::Class'); # ... test the classes themselves my $point = Point->new('x' => 2, 'y' => 3); isa_ok($point, 'Point'); can_ok($point, 'x'); can_ok($point, 'y'); can_ok($point, 'clear'); { my $meta = $point->meta; is($meta, Point->meta(), '... got the meta from the instance too'); } is($point->y, 3, '... the y attribute was initialized correctly through the metaobject'); $point->y(42); is($point->y, 42, '... the y attribute was set properly with the accessor'); is($point->x, 2, '... the x attribute was initialized correctly through the metaobject'); isnt( exception { $point->x(42); }, undef, '... cannot write to a read-only accessor' ); is($point->x, 2, '... the x attribute was not altered'); $point->clear(); is($point->y, 0, '... the y attribute was cleared correctly'); is($point->x, 0, '... the x attribute was cleared correctly'); my $point3d = Point3D->new('x' => 1, 'y' => 2, 'z' => 3); isa_ok($point3d, 'Point3D'); isa_ok($point3d, 'Point'); { my $meta = $point3d->meta; is($meta, Point3D->meta(), '... got the meta from the instance too'); } can_ok($point3d, 'x'); can_ok($point3d, 'y'); can_ok($point3d, 'clear'); is($point3d->x, 1, '... the x attribute was initialized correctly through the metaobject'); is($point3d->y, 2, '... the y attribute was initialized correctly through the metaobject'); is($point3d->{'z'}, 3, '... the z attribute was initialized correctly through the metaobject'); { my $point3d = Point3D->new(); isa_ok($point3d, 'Point3D'); is($point3d->x, undef, '... the x attribute was not initialized'); is($point3d->y, undef, '... the y attribute was not initialized'); is($point3d->{'z'}, 123, '... the z attribute was initialized correctly through the metaobject'); } done_testing; make_mutable.t100644000767000024 2222012200352344 16366 0ustar00etherstaff000000000000Moose-2.1005/t/cmopuse strict; use warnings; use Test::More; use Test::Fatal; use Scalar::Util; use Class::MOP; { package Foo; use strict; use warnings; use metaclass; __PACKAGE__->meta->add_attribute('bar'); package Bar; use strict; use warnings; use metaclass; __PACKAGE__->meta->superclasses('Foo'); __PACKAGE__->meta->add_attribute('baz'); package Baz; use strict; use warnings; use metaclass; __PACKAGE__->meta->superclasses('Bar'); __PACKAGE__->meta->add_attribute('bah'); } { my $meta = Baz->meta; is($meta->name, 'Baz', '... checking the Baz metaclass'); my %orig_keys = map { $_ => 1 } grep { !/^_/ } keys %$meta; # Since this has no default it won't be present yet, but it will # be after the class is made immutable. is( exception {$meta->make_immutable; }, undef, '... changed Baz to be immutable' ); ok(!$meta->is_mutable, '... our class is no longer mutable'); ok($meta->is_immutable, '... our class is now immutable'); ok($meta->make_immutable, '... make immutable returns true'); ok($meta->get_method('new'), '... inlined constructor created'); ok($meta->has_method('new'), '... inlined constructor created for sure'); is_deeply([ map { $_->name } $meta->_inlined_methods ], [ 'new' ], '... really, i mean it'); is( exception { $meta->make_mutable; }, undef, '... changed Baz to be mutable' ); ok($meta->is_mutable, '... our class is mutable'); ok(!$meta->is_immutable, '... our class is not immutable'); ok(!$meta->make_mutable, '... make mutable now returns nothing'); ok(!$meta->get_method('new'), '... inlined constructor created'); ok(!$meta->has_method('new'), '... inlined constructor removed for sure'); my %new_keys = map { $_ => 1 } grep { !/^_/ } keys %$meta; is_deeply(\%orig_keys, \%new_keys, '... no extraneous hashkeys'); isa_ok($meta, 'Class::MOP::Class', '... Baz->meta isa Class::MOP::Class'); $meta->add_method('xyz', sub{'xxx'}); is( Baz->xyz, 'xxx', '... method xyz works'); ok($meta->add_attribute('fickle', accessor => 'fickle'), '... added attribute'); ok(Baz->can('fickle'), '... Baz can fickle'); ok($meta->remove_attribute('fickle'), '... removed attribute'); my $reef = \ 'reef'; $meta->add_package_symbol('$ref', $reef); is($meta->get_package_symbol('$ref'), $reef, '... values match'); is( exception { $meta->remove_package_symbol('$ref') }, undef, '... removed it' ); isnt($meta->get_package_symbol('$ref'), $reef, '... values match'); ok( my @supers = $meta->superclasses, '... got the superclasses okay'); ok( $meta->superclasses('Foo'), '... set the superclasses'); is_deeply(['Foo'], [$meta->superclasses], '... set the superclasses okay'); ok( $meta->superclasses( @supers ), '... reset superclasses'); is_deeply([@supers], [$meta->superclasses], '... reset the superclasses okay'); ok( $meta->$_ , "... ${_} works") for qw(get_meta_instance get_all_attributes class_precedence_list ); is( exception {$meta->make_immutable; }, undef, '... changed Baz to be immutable again' ); ok($meta->get_method('new'), '... inlined constructor recreated'); } { my $meta = Baz->meta; is( exception { $meta->make_immutable() }, undef, 'Changed Baz to be immutable' ); is( exception { $meta->make_mutable() }, undef, '... changed Baz to be mutable' ); is( exception { $meta->make_immutable() }, undef, '... changed Baz to be immutable' ); isnt( exception { $meta->add_method('xyz', sub{'xxx'}) }, undef, '... exception thrown as expected' ); isnt( exception { $meta->add_attribute('fickle', accessor => 'fickle') }, undef, '... exception thrown as expected' ); isnt( exception { $meta->remove_attribute('fickle') }, undef, '... exception thrown as expected' ); my $reef = \ 'reef'; isnt( exception { $meta->add_package_symbol('$ref', $reef) }, undef, '... exception thrown as expected' ); isnt( exception { $meta->remove_package_symbol('$ref') }, undef, '... exception thrown as expected' ); ok( my @supers = $meta->superclasses, '... got the superclasses okay'); isnt( exception { $meta->superclasses('Foo') }, undef, '... set the superclasses' ); ok( $meta->$_ , "... ${_} works") for qw(get_meta_instance get_all_attributes class_precedence_list ); } { ok(Baz->meta->is_immutable, 'Superclass is immutable'); my $meta = Baz->meta->create_anon_class(superclasses => ['Baz']); my %orig_keys = map { $_ => 1 } grep { !/^_/ } keys %$meta; my @orig_meths = sort { $a->name cmp $b->name } $meta->get_all_methods; ok($meta->is_anon_class, 'We have an anon metaclass'); ok($meta->is_mutable, '... our anon class is mutable'); ok(!$meta->is_immutable, '... our anon class is not immutable'); is( exception {$meta->make_immutable( inline_accessor => 1, inline_destructor => 0, inline_constructor => 1, ) }, undef, '... changed class to be immutable' ); ok(!$meta->is_mutable, '... our class is no longer mutable'); ok($meta->is_immutable, '... our class is now immutable'); ok($meta->make_immutable, '... make immutable returns true'); is( exception { $meta->make_mutable }, undef, '... changed Baz to be mutable' ); ok($meta->is_mutable, '... our class is mutable'); ok(!$meta->is_immutable, '... our class is not immutable'); ok(!$meta->make_mutable, '... make mutable now returns nothing'); ok($meta->is_anon_class, '... still marked as an anon class'); my $instance = $meta->new_object; my %new_keys = map { $_ => 1 } grep { !/^_/ } keys %$meta; my @new_meths = sort { $a->name cmp $b->name } $meta->get_all_methods; is_deeply(\%orig_keys, \%new_keys, '... no extraneous hashkeys'); is_deeply(\@orig_meths, \@new_meths, '... no straneous methods'); isa_ok($meta, 'Class::MOP::Class', '... Anon class isa Class::MOP::Class'); $meta->add_method('xyz', sub{'xxx'}); is( $instance->xyz , 'xxx', '... method xyz works'); ok( $meta->remove_method('xyz'), '... removed method'); ok($meta->add_attribute('fickle', accessor => 'fickle'), '... added attribute'); ok($instance->can('fickle'), '... instance can fickle'); ok($meta->remove_attribute('fickle'), '... removed attribute'); my $reef = \ 'reef'; $meta->add_package_symbol('$ref', $reef); is($meta->get_package_symbol('$ref'), $reef, '... values match'); is( exception { $meta->remove_package_symbol('$ref') }, undef, '... removed it' ); isnt($meta->get_package_symbol('$ref'), $reef, '... values match'); ok( my @supers = $meta->superclasses, '... got the superclasses okay'); ok( $meta->superclasses('Foo'), '... set the superclasses'); is_deeply(['Foo'], [$meta->superclasses], '... set the superclasses okay'); ok( $meta->superclasses( @supers ), '... reset superclasses'); is_deeply([@supers], [$meta->superclasses], '... reset the superclasses okay'); ok( $meta->$_ , "... ${_} works") for qw(get_meta_instance get_all_attributes class_precedence_list ); }; #rerun the same tests on an anon class.. just cause we can. { my $meta = Baz->meta->create_anon_class(superclasses => ['Baz']); is( exception {$meta->make_immutable( inline_accessor => 1, inline_destructor => 0, inline_constructor => 1, ) }, undef, '... changed class to be immutable' ); is( exception { $meta->make_mutable() }, undef, '... changed class to be mutable' ); is( exception {$meta->make_immutable }, undef, '... changed class to be immutable' ); isnt( exception { $meta->add_method('xyz', sub{'xxx'}) }, undef, '... exception thrown as expected' ); isnt( exception { $meta->add_attribute('fickle', accessor => 'fickle') }, undef, '... exception thrown as expected' ); isnt( exception { $meta->remove_attribute('fickle') }, undef, '... exception thrown as expected' ); my $reef = \ 'reef'; isnt( exception { $meta->add_package_symbol('$ref', $reef) }, undef, '... exception thrown as expected' ); isnt( exception { $meta->remove_package_symbol('$ref') }, undef, '... exception thrown as expected' ); ok( my @supers = $meta->superclasses, '... got the superclasses okay'); isnt( exception { $meta->superclasses('Foo') }, undef, '... set the superclasses' ); ok( $meta->$_ , "... ${_} works") for qw(get_meta_instance get_all_attributes class_precedence_list ); } { Foo->meta->make_immutable; Bar->meta->make_immutable; Bar->meta->make_mutable; } done_testing; meta_package.t100644000767000024 2316212200352344 16347 0ustar00etherstaff000000000000Moose-2.1005/t/cmopuse strict; use warnings; use Test::More; use Test::Fatal; use Class::MOP; use Class::MOP::Package; isnt( exception { Class::MOP::Package->get_all_package_symbols }, undef, q{... can't call get_all_package_symbols() as a class method} ); isnt( exception { Class::MOP::Package->name }, undef, q{... can't call name() as a class method} ); { package Foo; use constant SOME_CONSTANT => 1; sub meta { Class::MOP::Package->initialize('Foo') } } # ---------------------------------------------------------------------- ## tests adding a HASH ok(!defined($Foo::{foo}), '... the %foo slot has not been created yet'); ok(!Foo->meta->has_package_symbol('%foo'), '... the meta agrees'); ok(!defined($Foo::{foo}), '... checking doesn\' vivify'); is( exception { Foo->meta->add_package_symbol('%foo' => { one => 1 }); }, undef, '... created %Foo::foo successfully' ); # ... scalar should NOT be created here ok(!Foo->meta->has_package_symbol('$foo'), '... SCALAR shouldnt have been created too'); ok(!Foo->meta->has_package_symbol('@foo'), '... ARRAY shouldnt have been created too'); ok(!Foo->meta->has_package_symbol('&foo'), '... CODE shouldnt have been created too'); ok(defined($Foo::{foo}), '... the %foo slot was created successfully'); ok(Foo->meta->has_package_symbol('%foo'), '... the meta agrees'); # check the value ... { no strict 'refs'; ok(exists ${'Foo::foo'}{one}, '... our %foo was initialized correctly'); is(${'Foo::foo'}{one}, 1, '... our %foo was initialized correctly'); } my $foo = Foo->meta->get_package_symbol('%foo'); is_deeply({ one => 1 }, $foo, '... got the right package variable back'); # ... make sure changes propogate up $foo->{two} = 2; { no strict 'refs'; is(\%{'Foo::foo'}, Foo->meta->get_package_symbol('%foo'), '... our %foo is the same as the metas'); ok(exists ${'Foo::foo'}{two}, '... our %foo was updated correctly'); is(${'Foo::foo'}{two}, 2, '... our %foo was updated correctly'); } # ---------------------------------------------------------------------- ## test adding an ARRAY ok(!defined($Foo::{bar}), '... the @bar slot has not been created yet'); is( exception { Foo->meta->add_package_symbol('@bar' => [ 1, 2, 3 ]); }, undef, '... created @Foo::bar successfully' ); ok(defined($Foo::{bar}), '... the @bar slot was created successfully'); ok(Foo->meta->has_package_symbol('@bar'), '... the meta agrees'); # ... why does this not work ... ok(!Foo->meta->has_package_symbol('$bar'), '... SCALAR shouldnt have been created too'); ok(!Foo->meta->has_package_symbol('%bar'), '... HASH shouldnt have been created too'); ok(!Foo->meta->has_package_symbol('&bar'), '... CODE shouldnt have been created too'); # check the value itself { no strict 'refs'; is(scalar @{'Foo::bar'}, 3, '... our @bar was initialized correctly'); is(${'Foo::bar'}[1], 2, '... our @bar was initialized correctly'); } # ---------------------------------------------------------------------- ## test adding a SCALAR ok(!defined($Foo::{baz}), '... the $baz slot has not been created yet'); is( exception { Foo->meta->add_package_symbol('$baz' => 10); }, undef, '... created $Foo::baz successfully' ); ok(defined($Foo::{baz}), '... the $baz slot was created successfully'); ok(Foo->meta->has_package_symbol('$baz'), '... the meta agrees'); ok(!Foo->meta->has_package_symbol('@baz'), '... ARRAY shouldnt have been created too'); ok(!Foo->meta->has_package_symbol('%baz'), '... HASH shouldnt have been created too'); ok(!Foo->meta->has_package_symbol('&baz'), '... CODE shouldnt have been created too'); is(${Foo->meta->get_package_symbol('$baz')}, 10, '... got the right value back'); { no strict 'refs'; ${'Foo::baz'} = 1; is(${'Foo::baz'}, 1, '... our $baz was assigned to correctly'); is(${Foo->meta->get_package_symbol('$baz')}, 1, '... the meta agrees'); } # ---------------------------------------------------------------------- ## test adding a CODE ok(!defined($Foo::{funk}), '... the &funk slot has not been created yet'); is( exception { Foo->meta->add_package_symbol('&funk' => sub { "Foo::funk" }); }, undef, '... created &Foo::funk successfully' ); ok(defined($Foo::{funk}), '... the &funk slot was created successfully'); ok(Foo->meta->has_package_symbol('&funk'), '... the meta agrees'); ok(!Foo->meta->has_package_symbol('$funk'), '... SCALAR shouldnt have been created too'); ok(!Foo->meta->has_package_symbol('@funk'), '... ARRAY shouldnt have been created too'); ok(!Foo->meta->has_package_symbol('%funk'), '... HASH shouldnt have been created too'); { no strict 'refs'; ok(defined &{'Foo::funk'}, '... our &funk exists'); } is(Foo->funk(), 'Foo::funk', '... got the right value from the function'); # ---------------------------------------------------------------------- ## test multiple slots in the glob my $ARRAY = [ 1, 2, 3 ]; my $CODE = sub { "Foo::foo" }; is( exception { Foo->meta->add_package_symbol('@foo' => $ARRAY); }, undef, '... created @Foo::foo successfully' ); ok(Foo->meta->has_package_symbol('@foo'), '... the @foo slot was added successfully'); is(Foo->meta->get_package_symbol('@foo'), $ARRAY, '... got the right values for @Foo::foo'); is( exception { Foo->meta->add_package_symbol('&foo' => $CODE); }, undef, '... created &Foo::foo successfully' ); ok(Foo->meta->has_package_symbol('&foo'), '... the meta agrees'); is(Foo->meta->get_package_symbol('&foo'), $CODE, '... got the right value for &Foo::foo'); is( exception { Foo->meta->add_package_symbol('$foo' => 'Foo::foo'); }, undef, '... created $Foo::foo successfully' ); ok(Foo->meta->has_package_symbol('$foo'), '... the meta agrees'); my $SCALAR = Foo->meta->get_package_symbol('$foo'); is($$SCALAR, 'Foo::foo', '... got the right scalar value back'); { no strict 'refs'; is(${'Foo::foo'}, 'Foo::foo', '... got the right value from the scalar'); } is( exception { Foo->meta->remove_package_symbol('%foo'); }, undef, '... removed %Foo::foo successfully' ); ok(!Foo->meta->has_package_symbol('%foo'), '... the %foo slot was removed successfully'); ok(Foo->meta->has_package_symbol('@foo'), '... the @foo slot still exists'); ok(Foo->meta->has_package_symbol('&foo'), '... the &foo slot still exists'); ok(Foo->meta->has_package_symbol('$foo'), '... the $foo slot still exists'); is(Foo->meta->get_package_symbol('@foo'), $ARRAY, '... got the right values for @Foo::foo'); is(Foo->meta->get_package_symbol('&foo'), $CODE, '... got the right value for &Foo::foo'); is(Foo->meta->get_package_symbol('$foo'), $SCALAR, '... got the right value for $Foo::foo'); { no strict 'refs'; ok(!defined(*{"Foo::foo"}{HASH}), '... the %foo slot has been removed successfully'); ok(defined(*{"Foo::foo"}{ARRAY}), '... the @foo slot has NOT been removed'); ok(defined(*{"Foo::foo"}{CODE}), '... the &foo slot has NOT been removed'); ok(defined(${"Foo::foo"}), '... the $foo slot has NOT been removed'); } is( exception { Foo->meta->remove_package_symbol('&foo'); }, undef, '... removed &Foo::foo successfully' ); ok(!Foo->meta->has_package_symbol('&foo'), '... the &foo slot no longer exists'); ok(Foo->meta->has_package_symbol('@foo'), '... the @foo slot still exists'); ok(Foo->meta->has_package_symbol('$foo'), '... the $foo slot still exists'); is(Foo->meta->get_package_symbol('@foo'), $ARRAY, '... got the right values for @Foo::foo'); is(Foo->meta->get_package_symbol('$foo'), $SCALAR, '... got the right value for $Foo::foo'); { no strict 'refs'; ok(!defined(*{"Foo::foo"}{HASH}), '... the %foo slot has been removed successfully'); ok(!defined(*{"Foo::foo"}{CODE}), '... the &foo slot has now been removed'); ok(defined(*{"Foo::foo"}{ARRAY}), '... the @foo slot has NOT been removed'); ok(defined(${"Foo::foo"}), '... the $foo slot has NOT been removed'); } is( exception { Foo->meta->remove_package_symbol('$foo'); }, undef, '... removed $Foo::foo successfully' ); ok(!Foo->meta->has_package_symbol('$foo'), '... the $foo slot no longer exists'); ok(Foo->meta->has_package_symbol('@foo'), '... the @foo slot still exists'); is(Foo->meta->get_package_symbol('@foo'), $ARRAY, '... got the right values for @Foo::foo'); { no strict 'refs'; ok(!defined(*{"Foo::foo"}{HASH}), '... the %foo slot has been removed successfully'); ok(!defined(*{"Foo::foo"}{CODE}), '... the &foo slot has now been removed'); ok(!defined(${"Foo::foo"}), '... the $foo slot has now been removed'); ok(defined(*{"Foo::foo"}{ARRAY}), '... the @foo slot has NOT been removed'); } # get_all_package_symbols { my $syms = Foo->meta->get_all_package_symbols; is_deeply( [ sort keys %{ $syms } ], [ sort Foo->meta->list_all_package_symbols ], '... the fetched symbols are the same as the listed ones' ); } { my $syms = Foo->meta->get_all_package_symbols('CODE'); is_deeply( [ sort keys %{ $syms } ], [ sort Foo->meta->list_all_package_symbols('CODE') ], '... the fetched symbols are the same as the listed ones' ); foreach my $symbol (keys %{ $syms }) { is($syms->{$symbol}, Foo->meta->get_package_symbol('&' . $symbol), '... got the right symbol'); } } { Foo->meta->add_package_symbol('%zork'); my $syms = Foo->meta->get_all_package_symbols('HASH'); is_deeply( [ sort keys %{ $syms } ], [ sort Foo->meta->list_all_package_symbols('HASH') ], '... the fetched symbols are the same as the listed ones' ); foreach my $symbol (keys %{ $syms }) { is($syms->{$symbol}, Foo->meta->get_package_symbol('%' . $symbol), '... got the right symbol'); } no warnings 'once'; is_deeply( $syms, { zork => \%Foo::zork }, "got the right ones", ); } done_testing; RT_27329_fix.t100644000767000024 151012200352344 15660 0ustar00etherstaff000000000000Moose-2.1005/t/cmopuse strict; use warnings; use Test::More; use Class::MOP; =pod This tests a bug sent via RT #27329 =cut { package Foo; use metaclass; Foo->meta->add_attribute('foo' => ( init_arg => 'foo', reader => 'get_foo', default => 'BAR', )); } my $foo = Foo->meta->new_object; isa_ok($foo, 'Foo'); is($foo->get_foo, 'BAR', '... got the right default value'); { my $clone = $foo->meta->clone_object($foo, foo => 'BAZ'); isa_ok($clone, 'Foo'); isnt($clone, $foo, '... and it is a clone'); is($clone->get_foo, 'BAZ', '... got the right cloned value'); } { my $clone = $foo->meta->clone_object($foo, foo => undef); isa_ok($clone, 'Foo'); isnt($clone, $foo, '... and it is a clone'); ok(!defined($clone->get_foo), '... got the right cloned value'); } done_testing; RT_39001_fix.t100644000767000024 131512200352344 15651 0ustar00etherstaff000000000000Moose-2.1005/t/cmopuse strict; use warnings; use Test::More; use Test::Fatal; use Class::MOP; =pod This tests a bug sent via RT #39001 =cut { package Foo; use metaclass; } like( exception { Foo->meta->superclasses('Foo'); }, qr/^Recursive inheritance detected/, "error occurs when extending oneself" ); { package Bar; use metaclass; } # reset @ISA, so that calling methods like ->isa won't die (->meta does this # if DEBUG_NO_META is set) @Foo::ISA = (); is( exception { Foo->meta->superclasses('Bar'); }, undef, "regular subclass" ); like( exception { Bar->meta->superclasses('Foo'); }, qr/^Recursive inheritance detected/, "error occurs when Bar extends Foo, when Foo is a Bar" ); done_testing; examples000755000767000024 012200352344 14255 5ustar00etherstaff000000000000Moose-2.1005/texample1.t100644000767000024 674412200352344 16331 0ustar00etherstaff000000000000Moose-2.1005/t/examples#!/usr/bin/perl use strict; use warnings; use Test::More; ## Roles { package Constraint; use Moose::Role; has 'value' => (isa => 'Num', is => 'ro'); around 'validate' => sub { my $c = shift; my ($self, $field) = @_; return undef if $c->($self, $self->validation_value($field)); return $self->error_message; }; sub validation_value { my ($self, $field) = @_; return $field; } sub error_message { confess "Abstract method!" } package Constraint::OnLength; use Moose::Role; has 'units' => (isa => 'Str', is => 'ro'); override 'validation_value' => sub { return length(super()); }; override 'error_message' => sub { my $self = shift; return super() . ' ' . $self->units; }; } ## Classes { package Constraint::AtLeast; use Moose; with 'Constraint'; sub validate { my ($self, $field) = @_; ($field >= $self->value); } sub error_message { 'must be at least ' . (shift)->value; } package Constraint::NoMoreThan; use Moose; with 'Constraint'; sub validate { my ($self, $field) = @_; ($field <= $self->value); } sub error_message { 'must be no more than ' . (shift)->value; } package Constraint::LengthNoMoreThan; use Moose; extends 'Constraint::NoMoreThan'; with 'Constraint::OnLength'; package Constraint::LengthAtLeast; use Moose; extends 'Constraint::AtLeast'; with 'Constraint::OnLength'; } my $no_more_than_10 = Constraint::NoMoreThan->new(value => 10); isa_ok($no_more_than_10, 'Constraint::NoMoreThan'); ok($no_more_than_10->does('Constraint'), '... Constraint::NoMoreThan does Constraint'); ok(!defined($no_more_than_10->validate(1)), '... validated correctly'); is($no_more_than_10->validate(11), 'must be no more than 10', '... validation failed correctly'); my $at_least_10 = Constraint::AtLeast->new(value => 10); isa_ok($at_least_10, 'Constraint::AtLeast'); ok($at_least_10->does('Constraint'), '... Constraint::AtLeast does Constraint'); ok(!defined($at_least_10->validate(11)), '... validated correctly'); is($at_least_10->validate(1), 'must be at least 10', '... validation failed correctly'); # onlength my $no_more_than_10_chars = Constraint::LengthNoMoreThan->new(value => 10, units => 'chars'); isa_ok($no_more_than_10_chars, 'Constraint::LengthNoMoreThan'); isa_ok($no_more_than_10_chars, 'Constraint::NoMoreThan'); ok($no_more_than_10_chars->does('Constraint'), '... Constraint::LengthNoMoreThan does Constraint'); ok($no_more_than_10_chars->does('Constraint::OnLength'), '... Constraint::LengthNoMoreThan does Constraint::OnLength'); ok(!defined($no_more_than_10_chars->validate('foo')), '... validated correctly'); is($no_more_than_10_chars->validate('foooooooooo'), 'must be no more than 10 chars', '... validation failed correctly'); my $at_least_10_chars = Constraint::LengthAtLeast->new(value => 10, units => 'chars'); isa_ok($at_least_10_chars, 'Constraint::LengthAtLeast'); isa_ok($at_least_10_chars, 'Constraint::AtLeast'); ok($at_least_10_chars->does('Constraint'), '... Constraint::LengthAtLeast does Constraint'); ok($at_least_10_chars->does('Constraint::OnLength'), '... Constraint::LengthAtLeast does Constraint::OnLength'); ok(!defined($at_least_10_chars->validate('barrrrrrrrr')), '... validated correctly'); is($at_least_10_chars->validate('bar'), 'must be at least 10 chars', '... validation failed correctly'); done_testing; example2.t100644000767000024 772412200352344 16331 0ustar00etherstaff000000000000Moose-2.1005/t/examples#!/usr/bin/perl use strict; use warnings; use Test::More; use Test::Fatal; sub U { my $f = shift; sub { $f->($f, @_) }; } sub Y { my $f = shift; U(sub { my $h = shift; sub { $f->(U($h)->())->(@_) } })->(); } { package List; use Moose::Role; has '_list' => ( is => 'ro', isa => 'ArrayRef', init_arg => '::', default => sub { [] } ); sub head { (shift)->_list->[0] } sub tail { my $self = shift; (ref $self)->new( '::' => [ @{$self->_list}[1 .. $#{$self->_list}] ] ); } sub print { join ", " => @{$_[0]->_list}; } package List::Immutable; use Moose::Role; requires 'head'; requires 'tail'; sub is_empty { not defined ($_[0]->head) } sub length { my $self = shift; (::Y(sub { my $redo = shift; sub { my ($list, $acc) = @_; return $acc if $list->is_empty; $redo->($list->tail, $acc + 1); } }))->($self, 0); } sub apply { my ($self, $function) = @_; (::Y(sub { my $redo = shift; sub { my ($list, $func, $acc) = @_; return (ref $list)->new('::' => $acc) if $list->is_empty; $redo->( $list->tail, $func, [ @{$acc}, $func->($list->head) ] ); } }))->($self, $function, []); } package My::List1; use Moose; ::is( ::exception { with 'List', 'List::Immutable'; }, undef, '... successfully composed roles together' ); package My::List2; use Moose; ::is( ::exception { with 'List::Immutable', 'List'; }, undef, '... successfully composed roles together' ); } { my $coll = My::List1->new; isa_ok($coll, 'My::List1'); ok($coll->does('List'), '... $coll does List'); ok($coll->does('List::Immutable'), '... $coll does List::Immutable'); ok($coll->is_empty, '... we have an empty collection'); is($coll->length, 0, '... we have a length of 1 for the collection'); } { my $coll = My::List2->new; isa_ok($coll, 'My::List2'); ok($coll->does('List'), '... $coll does List'); ok($coll->does('List::Immutable'), '... $coll does List::Immutable'); ok($coll->is_empty, '... we have an empty collection'); is($coll->length, 0, '... we have a length of 1 for the collection'); } { my $coll = My::List1->new('::' => [ 1 .. 10 ]); isa_ok($coll, 'My::List1'); ok($coll->does('List'), '... $coll does List'); ok($coll->does('List::Immutable'), '... $coll does List::Immutable'); ok(!$coll->is_empty, '... we do not have an empty collection'); is($coll->length, 10, '... we have a length of 10 for the collection'); is($coll->print, '1, 2, 3, 4, 5, 6, 7, 8, 9, 10', '... got the right printed value'); my $coll2 = $coll->apply(sub { $_[0] * $_[0] }); isa_ok($coll2, 'My::List1'); is($coll->print, '1, 2, 3, 4, 5, 6, 7, 8, 9, 10', '... original is still the same'); is($coll2->print, '1, 4, 9, 16, 25, 36, 49, 64, 81, 100', '... new collection is changed'); } { my $coll = My::List2->new('::' => [ 1 .. 10 ]); isa_ok($coll, 'My::List2'); ok($coll->does('List'), '... $coll does List'); ok($coll->does('List::Immutable'), '... $coll does List::Immutable'); ok(!$coll->is_empty, '... we do not have an empty collection'); is($coll->length, 10, '... we have a length of 10 for the collection'); is($coll->print, '1, 2, 3, 4, 5, 6, 7, 8, 9, 10', '... got the right printed value'); my $coll2 = $coll->apply(sub { $_[0] * $_[0] }); isa_ok($coll2, 'My::List2'); is($coll->print, '1, 2, 3, 4, 5, 6, 7, 8, 9, 10', '... original is still the same'); is($coll2->print, '1, 4, 9, 16, 25, 36, 49, 64, 81, 100', '... new collection is changed'); } done_testing; create_role.t100644000767000024 166512200352344 16404 0ustar00etherstaff000000000000Moose-2.1005/t/roles#!/usr/bin/env perl use strict; use warnings; use Test::More; use Moose (); my $role = Moose::Meta::Role->create( 'MyItem::Role::Equipment', attributes => { is_worn => { is => 'rw', isa => 'Bool', }, }, methods => { remove => sub { shift->is_worn(0) }, }, ); my $class = Moose::Meta::Class->create('MyItem::Armor::Helmet' => roles => ['MyItem::Role::Equipment'], ); my $visored = $class->new_object(is_worn => 0); ok(!$visored->is_worn, "attribute, accessor was consumed"); $visored->is_worn(1); ok($visored->is_worn, "accessor was consumed"); $visored->remove; ok(!$visored->is_worn, "method was consumed"); ok(!$role->is_anon_role, "the role is not anonymous"); my $composed_role = Moose::Meta::Role->create( 'MyItem::Role::Equipment2', roles => [ $role ], ); ok($composed_role->does_role('MyItem::Role::Equipment2'), "Role composed into role"); done_testing; cmop000755000767000024 012200352344 15247 5ustar00etherstaff000000000000Moose-2.1005/benchmarksfoo.pl100755000767000024 15112200352344 16507 0ustar00etherstaff000000000000Moose-2.1005/benchmarks/cmop#!perl -wd:NYTProf # a moose using script for profiling # Usage: perl bench/profile.pl require KiokuDB; examples000755000767000024 012200352344 14012 5ustar00etherstaff000000000000Moose-2.1005LazyClass.pod100644000767000024 735212200352344 16572 0ustar00etherstaff000000000000Moose-2.1005/examples package # hide the package from PAUSE LazyClass::Attribute; use strict; use warnings; use Carp 'confess'; our $VERSION = '0.05'; use base 'Class::MOP::Attribute'; sub initialize_instance_slot { my ($self, $meta_instance, $instance, $params) = @_; # if the attr has an init_arg, use that, otherwise, # use the attributes name itself as the init_arg my $init_arg = $self->init_arg(); if ( exists $params->{$init_arg} ) { my $val = $params->{$init_arg}; $meta_instance->set_slot_value($instance, $self->name, $val); } } sub accessor_metaclass { 'LazyClass::Method::Accessor' } package # hide the package from PAUSE LazyClass::Method::Accessor; use strict; use warnings; use Carp 'confess'; our $VERSION = '0.01'; use base 'Class::MOP::Method::Accessor'; sub _generate_accessor_method { my $attr = (shift)->associated_attribute; my $attr_name = $attr->name; my $meta_instance = $attr->associated_class->get_meta_instance; sub { if (scalar(@_) == 2) { $meta_instance->set_slot_value($_[0], $attr_name, $_[1]); } else { unless ( $meta_instance->is_slot_initialized($_[0], $attr_name) ) { my $value = $attr->has_default ? $attr->default($_[0]) : undef; $meta_instance->set_slot_value($_[0], $attr_name, $value); } $meta_instance->get_slot_value($_[0], $attr_name); } }; } sub _generate_reader_method { my $attr = (shift)->associated_attribute; my $attr_name = $attr->name; my $meta_instance = $attr->associated_class->get_meta_instance; sub { confess "Cannot assign a value to a read-only accessor" if @_ > 1; unless ( $meta_instance->is_slot_initialized($_[0], $attr_name) ) { my $value = $attr->has_default ? $attr->default($_[0]) : undef; $meta_instance->set_slot_value($_[0], $attr_name, $value); } $meta_instance->get_slot_value($_[0], $attr_name); }; } package # hide the package from PAUSE LazyClass::Instance; use strict; use warnings; our $VERSION = '0.01'; use base 'Class::MOP::Instance'; sub initialize_all_slots {} 1; __END__ =pod =head1 NAME LazyClass - An example metaclass with lazy initialization =head1 SYNOPSIS package BinaryTree; use metaclass ( ':attribute_metaclass' => 'LazyClass::Attribute', ':instance_metaclass' => 'LazyClass::Instance', ); BinaryTree->meta->add_attribute('node' => ( accessor => 'node', init_arg => ':node' )); BinaryTree->meta->add_attribute('left' => ( reader => 'left', default => sub { BinaryTree->new() } )); BinaryTree->meta->add_attribute('right' => ( reader => 'right', default => sub { BinaryTree->new() } )); sub new { my $class = shift; $class->meta->new_object(@_); } # ... later in code my $btree = BinaryTree->new(); # ... $btree is an empty hash, no keys are initialized yet =head1 DESCRIPTION This is an example metclass in which all attributes are created lazily. This means that no entries are made in the instance HASH until the last possible moment. The example above of a binary tree is a good use for such a metaclass because it allows the class to be space efficient without complicating the programing of it. This would also be ideal for a class which has a large amount of attributes, several of which are optional. =head1 AUTHORS Stevan Little Estevan@iinteractive.comE Yuval Kogman Enothingmuch@woobling.comE =head1 COPYRIGHT AND LICENSE Copyright 2006-2008 by Infinity Interactive, Inc. L This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut MOP000755000767000024 012200352344 14442 5ustar00etherstaff000000000000Moose-2.1005/lib/ClassClass.pm100644000767000024 20124312200352344 16247 0ustar00etherstaff000000000000Moose-2.1005/lib/Class/MOP package Class::MOP::Class; BEGIN { $Class::MOP::Class::AUTHORITY = 'cpan:STEVAN'; } { $Class::MOP::Class::VERSION = '2.1005'; } use strict; use warnings; use Class::MOP::Instance; use Class::MOP::Method::Wrapped; use Class::MOP::Method::Accessor; use Class::MOP::Method::Constructor; use Class::MOP::MiniTrait; use Carp 'confess'; use Class::Load 'is_class_loaded', 'load_class'; use Scalar::Util 'blessed', 'reftype', 'weaken'; use Sub::Name 'subname'; use Try::Tiny; use List::MoreUtils 'all'; use base 'Class::MOP::Module', 'Class::MOP::Mixin::HasAttributes', 'Class::MOP::Mixin::HasMethods'; # Creation sub initialize { my $class = shift; my $package_name; if ( @_ % 2 ) { $package_name = shift; } else { my %options = @_; $package_name = $options{package}; } ($package_name && !ref($package_name)) || confess "You must pass a package name and it cannot be blessed"; return Class::MOP::get_metaclass_by_name($package_name) || $class->_construct_class_instance(package => $package_name, @_); } sub reinitialize { my ( $class, @args ) = @_; unshift @args, "package" if @args % 2; my %options = @args; my $old_metaclass = blessed($options{package}) ? $options{package} : Class::MOP::get_metaclass_by_name($options{package}); $options{weaken} = Class::MOP::metaclass_is_weak($old_metaclass->name) if !exists $options{weaken} && blessed($old_metaclass) && $old_metaclass->isa('Class::MOP::Class'); $old_metaclass->_remove_generated_metaobjects if $old_metaclass && $old_metaclass->isa('Class::MOP::Class'); my $new_metaclass = $class->SUPER::reinitialize(%options); $new_metaclass->_restore_metaobjects_from($old_metaclass) if $old_metaclass && $old_metaclass->isa('Class::MOP::Class'); return $new_metaclass; } # NOTE: (meta-circularity) # this is a special form of _construct_instance # (see below), which is used to construct class # meta-object instances for any Class::MOP::* # class. All other classes will use the more # normal &construct_instance. sub _construct_class_instance { my $class = shift; my $options = @_ == 1 ? $_[0] : {@_}; my $package_name = $options->{package}; (defined $package_name && $package_name) || confess "You must pass a package name"; # NOTE: # return the metaclass if we have it cached, # and it is still defined (it has not been # reaped by DESTROY yet, which can happen # annoyingly enough during global destruction) if (defined(my $meta = Class::MOP::get_metaclass_by_name($package_name))) { return $meta; } $class = ref $class ? $class->_real_ref_name : $class; # now create the metaclass my $meta; if ($class eq 'Class::MOP::Class') { $meta = $class->_new($options); } else { # NOTE: # it is safe to use meta here because # class will always be a subclass of # Class::MOP::Class, which defines meta $meta = $class->meta->_construct_instance($options) } # and check the metaclass compatibility $meta->_check_metaclass_compatibility(); Class::MOP::store_metaclass_by_name($package_name, $meta); # NOTE: # we need to weaken any anon classes # so that they can call DESTROY properly Class::MOP::weaken_metaclass($package_name) if $options->{weaken}; $meta; } sub _real_ref_name { my $self = shift; # NOTE: we need to deal with the possibility of class immutability here, # and then get the name of the class appropriately return $self->is_immutable ? $self->_get_mutable_metaclass_name() : ref $self; } sub _new { my $class = shift; return Class::MOP::Class->initialize($class)->new_object(@_) if $class ne __PACKAGE__; my $options = @_ == 1 ? $_[0] : {@_}; return bless { # inherited from Class::MOP::Package 'package' => $options->{package}, # NOTE: # since the following attributes will # actually be loaded from the symbol # table, and actually bypass the instance # entirely, we can just leave these things # listed here for reference, because they # should not actually have a value associated # with the slot. 'namespace' => \undef, 'methods' => {}, # inherited from Class::MOP::Module 'version' => \undef, 'authority' => \undef, # defined in Class::MOP::Class 'superclasses' => \undef, 'attributes' => {}, 'attribute_metaclass' => ( $options->{'attribute_metaclass'} || 'Class::MOP::Attribute' ), 'method_metaclass' => ( $options->{'method_metaclass'} || 'Class::MOP::Method' ), 'wrapped_method_metaclass' => ( $options->{'wrapped_method_metaclass'} || 'Class::MOP::Method::Wrapped' ), 'instance_metaclass' => ( $options->{'instance_metaclass'} || 'Class::MOP::Instance' ), 'immutable_trait' => ( $options->{'immutable_trait'} || 'Class::MOP::Class::Immutable::Trait' ), 'constructor_name' => ( $options->{constructor_name} || 'new' ), 'constructor_class' => ( $options->{constructor_class} || 'Class::MOP::Method::Constructor' ), 'destructor_class' => $options->{destructor_class}, }, $class; } ## Metaclass compatibility { my %base_metaclass = ( attribute_metaclass => 'Class::MOP::Attribute', method_metaclass => 'Class::MOP::Method', wrapped_method_metaclass => 'Class::MOP::Method::Wrapped', instance_metaclass => 'Class::MOP::Instance', constructor_class => 'Class::MOP::Method::Constructor', destructor_class => 'Class::MOP::Method::Destructor', ); sub _base_metaclasses { %base_metaclass } } sub _check_metaclass_compatibility { my $self = shift; my @superclasses = $self->superclasses or return; $self->_fix_metaclass_incompatibility(@superclasses); my %base_metaclass = $self->_base_metaclasses; # this is always okay ... return if ref($self) eq 'Class::MOP::Class' && all { my $meta = $self->$_; !defined($meta) || $meta eq $base_metaclass{$_}; } keys %base_metaclass; for my $superclass (@superclasses) { $self->_check_class_metaclass_compatibility($superclass); } for my $metaclass_type ( keys %base_metaclass ) { next unless defined $self->$metaclass_type; for my $superclass (@superclasses) { $self->_check_single_metaclass_compatibility( $metaclass_type, $superclass ); } } } sub _check_class_metaclass_compatibility { my $self = shift; my ( $superclass_name ) = @_; if (!$self->_class_metaclass_is_compatible($superclass_name)) { my $super_meta = Class::MOP::get_metaclass_by_name($superclass_name); my $super_meta_type = $super_meta->_real_ref_name; confess "The metaclass of " . $self->name . " (" . (ref($self)) . ")" . " is not compatible with " . "the metaclass of its superclass, " . $superclass_name . " (" . ($super_meta_type) . ")"; } } sub _class_metaclass_is_compatible { my $self = shift; my ( $superclass_name ) = @_; my $super_meta = Class::MOP::get_metaclass_by_name($superclass_name) || return 1; my $super_meta_name = $super_meta->_real_ref_name; return $self->_is_compatible_with($super_meta_name); } sub _check_single_metaclass_compatibility { my $self = shift; my ( $metaclass_type, $superclass_name ) = @_; if (!$self->_single_metaclass_is_compatible($metaclass_type, $superclass_name)) { my $super_meta = Class::MOP::get_metaclass_by_name($superclass_name); my $metaclass_type_name = $metaclass_type; $metaclass_type_name =~ s/_(?:meta)?class$//; $metaclass_type_name =~ s/_/ /g; confess "The $metaclass_type_name metaclass for " . $self->name . " (" . ($self->$metaclass_type) . ")" . " is not compatible with the " . "$metaclass_type_name metaclass of its " . "superclass, $superclass_name (" . ($super_meta->$metaclass_type) . ")"; } } sub _single_metaclass_is_compatible { my $self = shift; my ( $metaclass_type, $superclass_name ) = @_; my $super_meta = Class::MOP::get_metaclass_by_name($superclass_name) || return 1; # for instance, Moose::Meta::Class has a error_class attribute, but # Class::MOP::Class doesn't - this shouldn't be an error return 1 unless $super_meta->can($metaclass_type); # for instance, Moose::Meta::Class has a destructor_class, but # Class::MOP::Class doesn't - this shouldn't be an error return 1 unless defined $super_meta->$metaclass_type; # if metaclass is defined in superclass but not here, it's not compatible # this is a really odd case return 0 unless defined $self->$metaclass_type; return $self->$metaclass_type->_is_compatible_with($super_meta->$metaclass_type); } sub _fix_metaclass_incompatibility { my $self = shift; my @supers = map { Class::MOP::Class->initialize($_) } @_; my $necessary = 0; for my $super (@supers) { $necessary = 1 if $self->_can_fix_metaclass_incompatibility($super); } return unless $necessary; for my $super (@supers) { if (!$self->_class_metaclass_is_compatible($super->name)) { $self->_fix_class_metaclass_incompatibility($super); } } my %base_metaclass = $self->_base_metaclasses; for my $metaclass_type (keys %base_metaclass) { for my $super (@supers) { if (!$self->_single_metaclass_is_compatible($metaclass_type, $super->name)) { $self->_fix_single_metaclass_incompatibility( $metaclass_type, $super ); } } } } sub _can_fix_metaclass_incompatibility { my $self = shift; my ($super_meta) = @_; return 1 if $self->_class_metaclass_can_be_made_compatible($super_meta); my %base_metaclass = $self->_base_metaclasses; for my $metaclass_type (keys %base_metaclass) { return 1 if $self->_single_metaclass_can_be_made_compatible($super_meta, $metaclass_type); } return; } sub _class_metaclass_can_be_made_compatible { my $self = shift; my ($super_meta) = @_; return $self->_can_be_made_compatible_with($super_meta->_real_ref_name); } sub _single_metaclass_can_be_made_compatible { my $self = shift; my ($super_meta, $metaclass_type) = @_; my $specific_meta = $self->$metaclass_type; return unless $super_meta->can($metaclass_type); my $super_specific_meta = $super_meta->$metaclass_type; # for instance, Moose::Meta::Class has a destructor_class, but # Class::MOP::Class doesn't - this shouldn't be an error return unless defined $super_specific_meta; # if metaclass is defined in superclass but not here, it's fixable # this is a really odd case return 1 unless defined $specific_meta; return 1 if $specific_meta->_can_be_made_compatible_with($super_specific_meta); } sub _fix_class_metaclass_incompatibility { my $self = shift; my ( $super_meta ) = @_; if ($self->_class_metaclass_can_be_made_compatible($super_meta)) { ($self->is_pristine) || confess "Can't fix metaclass incompatibility for " . $self->name . " because it is not pristine."; my $super_meta_name = $super_meta->_real_ref_name; $self->_make_compatible_with($super_meta_name); } } sub _fix_single_metaclass_incompatibility { my $self = shift; my ( $metaclass_type, $super_meta ) = @_; if ($self->_single_metaclass_can_be_made_compatible($super_meta, $metaclass_type)) { ($self->is_pristine) || confess "Can't fix metaclass incompatibility for " . $self->name . " because it is not pristine."; my $new_metaclass = $self->$metaclass_type ? $self->$metaclass_type->_get_compatible_metaclass($super_meta->$metaclass_type) : $super_meta->$metaclass_type; $self->{$metaclass_type} = $new_metaclass; } } sub _restore_metaobjects_from { my $self = shift; my ($old_meta) = @_; $self->_restore_metamethods_from($old_meta); $self->_restore_metaattributes_from($old_meta); } sub _remove_generated_metaobjects { my $self = shift; for my $attr (map { $self->get_attribute($_) } $self->get_attribute_list) { $attr->remove_accessors; } } # creating classes with MOP ... sub create { my $class = shift; my @args = @_; unshift @args, 'package' if @args % 2 == 1; my %options = @args; (ref $options{superclasses} eq 'ARRAY') || confess "You must pass an ARRAY ref of superclasses" if exists $options{superclasses}; (ref $options{attributes} eq 'ARRAY') || confess "You must pass an ARRAY ref of attributes" if exists $options{attributes}; (ref $options{methods} eq 'HASH') || confess "You must pass a HASH ref of methods" if exists $options{methods}; my $package = delete $options{package}; my $superclasses = delete $options{superclasses}; my $attributes = delete $options{attributes}; my $methods = delete $options{methods}; my $meta_name = exists $options{meta_name} ? delete $options{meta_name} : 'meta'; my $meta = $class->SUPER::create($package => %options); $meta->_add_meta_method($meta_name) if defined $meta_name; $meta->superclasses(@{$superclasses}) if defined $superclasses; # NOTE: # process attributes first, so that they can # install accessors, but locally defined methods # can then overwrite them. It is maybe a little odd, but # I think this should be the order of things. if (defined $attributes) { foreach my $attr (@{$attributes}) { $meta->add_attribute($attr); } } if (defined $methods) { foreach my $method_name (keys %{$methods}) { $meta->add_method($method_name, $methods->{$method_name}); } } return $meta; } # XXX: something more intelligent here? sub _anon_package_prefix { 'Class::MOP::Class::__ANON__::SERIAL::' } sub create_anon_class { shift->create_anon(@_) } sub is_anon_class { shift->is_anon(@_) } sub _anon_cache_key { my $class = shift; my %options = @_; # Makes something like Super::Class|Super::Class::2 return join '=' => ( join( '|', sort @{ $options{superclasses} || [] } ), ); } # Instance Construction & Cloning sub new_object { my $class = shift; # NOTE: # we need to protect the integrity of the # Class::MOP::Class singletons here, so we # delegate this to &construct_class_instance # which will deal with the singletons return $class->_construct_class_instance(@_) if $class->name->isa('Class::MOP::Class'); return $class->_construct_instance(@_); } sub _construct_instance { my $class = shift; my $params = @_ == 1 ? $_[0] : {@_}; my $meta_instance = $class->get_meta_instance(); # FIXME: # the code below is almost certainly incorrect # but this is foreign inheritance, so we might # have to kludge it in the end. my $instance; if (my $instance_class = blessed($params->{__INSTANCE__})) { ($instance_class eq $class->name) || confess "Objects passed as the __INSTANCE__ parameter must " . "already be blessed into the correct class, but " . "$params->{__INSTANCE__} is not a " . $class->name; $instance = $params->{__INSTANCE__}; } elsif (exists $params->{__INSTANCE__}) { confess "The __INSTANCE__ parameter must be a blessed reference, not " . $params->{__INSTANCE__}; } else { $instance = $meta_instance->create_instance(); } foreach my $attr ($class->get_all_attributes()) { $attr->initialize_instance_slot($meta_instance, $instance, $params); } if (Class::MOP::metaclass_is_weak($class->name)) { $meta_instance->_set_mop_slot($instance, $class); } return $instance; } sub _inline_new_object { my $self = shift; return ( 'my $class = shift;', '$class = Scalar::Util::blessed($class) || $class;', $self->_inline_fallback_constructor('$class'), $self->_inline_params('$params', '$class'), $self->_inline_generate_instance('$instance', '$class'), $self->_inline_slot_initializers, $self->_inline_preserve_weak_metaclasses, $self->_inline_extra_init, 'return $instance', ); } sub _inline_fallback_constructor { my $self = shift; my ($class) = @_; return ( 'return ' . $self->_generate_fallback_constructor($class), 'if ' . $class . ' ne \'' . $self->name . '\';', ); } sub _generate_fallback_constructor { my $self = shift; my ($class) = @_; return 'Class::MOP::Class->initialize(' . $class . ')->new_object(@_)', } sub _inline_params { my $self = shift; my ($params, $class) = @_; return ( 'my ' . $params . ' = @_ == 1 ? $_[0] : {@_};', ); } sub _inline_generate_instance { my $self = shift; my ($inst, $class) = @_; return ( 'my ' . $inst . ' = ' . $self->_inline_create_instance($class) . ';', ); } sub _inline_create_instance { my $self = shift; return $self->get_meta_instance->inline_create_instance(@_); } sub _inline_slot_initializers { my $self = shift; my $idx = 0; return map { $self->_inline_slot_initializer($_, $idx++) } sort { $a->name cmp $b->name } $self->get_all_attributes; } sub _inline_slot_initializer { my $self = shift; my ($attr, $idx) = @_; if (defined(my $init_arg = $attr->init_arg)) { my @source = ( 'if (exists $params->{\'' . $init_arg . '\'}) {', $self->_inline_init_attr_from_constructor($attr, $idx), '}', ); if (my @default = $self->_inline_init_attr_from_default($attr, $idx)) { push @source, ( 'else {', @default, '}', ); } return @source; } elsif (my @default = $self->_inline_init_attr_from_default($attr, $idx)) { return ( '{', @default, '}', ); } else { return (); } } sub _inline_init_attr_from_constructor { my $self = shift; my ($attr, $idx) = @_; my @initial_value = $attr->_inline_set_value( '$instance', '$params->{\'' . $attr->init_arg . '\'}', ); push @initial_value, ( '$attrs->[' . $idx . ']->set_initial_value(', '$instance,', $attr->_inline_instance_get('$instance'), ');', ) if $attr->has_initializer; return @initial_value; } sub _inline_init_attr_from_default { my $self = shift; my ($attr, $idx) = @_; my $default = $self->_inline_default_value($attr, $idx); return unless $default; my @initial_value = $attr->_inline_set_value('$instance', $default); push @initial_value, ( '$attrs->[' . $idx . ']->set_initial_value(', '$instance,', $attr->_inline_instance_get('$instance'), ');', ) if $attr->has_initializer; return @initial_value; } sub _inline_default_value { my $self = shift; my ($attr, $index) = @_; if ($attr->has_default) { # NOTE: # default values can either be CODE refs # in which case we need to call them. Or # they can be scalars (strings/numbers) # in which case we can just deal with them # in the code we eval. if ($attr->is_default_a_coderef) { return '$defaults->[' . $index . ']->($instance)'; } else { return '$defaults->[' . $index . ']'; } } elsif ($attr->has_builder) { return '$instance->' . $attr->builder; } else { return; } } sub _inline_preserve_weak_metaclasses { my $self = shift; if (Class::MOP::metaclass_is_weak($self->name)) { return ( $self->_inline_set_mop_slot( '$instance', 'Class::MOP::class_of($class)' ) . ';' ); } else { return (); } } sub _inline_extra_init { } sub _eval_environment { my $self = shift; my @attrs = sort { $a->name cmp $b->name } $self->get_all_attributes; my $defaults = [map { $_->default } @attrs]; return { '$defaults' => \$defaults, }; } sub get_meta_instance { my $self = shift; $self->{'_meta_instance'} ||= $self->_create_meta_instance(); } sub _create_meta_instance { my $self = shift; my $instance = $self->instance_metaclass->new( associated_metaclass => $self, attributes => [ $self->get_all_attributes() ], ); $self->add_meta_instance_dependencies() if $instance->is_dependent_on_superclasses(); return $instance; } # TODO: this is actually not being used! sub _inline_rebless_instance { my $self = shift; return $self->get_meta_instance->inline_rebless_instance_structure(@_); } sub _inline_get_mop_slot { my $self = shift; return $self->get_meta_instance->_inline_get_mop_slot(@_); } sub _inline_set_mop_slot { my $self = shift; return $self->get_meta_instance->_inline_set_mop_slot(@_); } sub _inline_clear_mop_slot { my $self = shift; return $self->get_meta_instance->_inline_clear_mop_slot(@_); } sub clone_object { my $class = shift; my $instance = shift; (blessed($instance) && $instance->isa($class->name)) || confess "You must pass an instance of the metaclass (" . (ref $class ? $class->name : $class) . "), not ($instance)"; # NOTE: # we need to protect the integrity of the # Class::MOP::Class singletons here, they # should not be cloned. return $instance if $instance->isa('Class::MOP::Class'); $class->_clone_instance($instance, @_); } sub _clone_instance { my ($class, $instance, %params) = @_; (blessed($instance)) || confess "You can only clone instances, ($instance) is not a blessed instance"; my $meta_instance = $class->get_meta_instance(); my $clone = $meta_instance->clone_instance($instance); foreach my $attr ($class->get_all_attributes()) { if ( defined( my $init_arg = $attr->init_arg ) ) { if (exists $params{$init_arg}) { $attr->set_value($clone, $params{$init_arg}); } } } return $clone; } sub _force_rebless_instance { my ($self, $instance, %params) = @_; my $old_metaclass = Class::MOP::class_of($instance); $old_metaclass->rebless_instance_away($instance, $self, %params) if $old_metaclass; my $meta_instance = $self->get_meta_instance; if (Class::MOP::metaclass_is_weak($old_metaclass->name)) { $meta_instance->_clear_mop_slot($instance); } # rebless! # we use $_[1] here because of t/cmop/rebless_overload.t regressions # on 5.8.8 $meta_instance->rebless_instance_structure($_[1], $self); $self->_fixup_attributes_after_rebless($instance, $old_metaclass, %params); if (Class::MOP::metaclass_is_weak($self->name)) { $meta_instance->_set_mop_slot($instance, $self); } } sub rebless_instance { my ($self, $instance, %params) = @_; my $old_metaclass = Class::MOP::class_of($instance); my $old_class = $old_metaclass ? $old_metaclass->name : blessed($instance); $self->name->isa($old_class) || confess "You may rebless only into a subclass of ($old_class), of which (". $self->name .") isn't."; $self->_force_rebless_instance($_[1], %params); return $instance; } sub rebless_instance_back { my ( $self, $instance ) = @_; my $old_metaclass = Class::MOP::class_of($instance); my $old_class = $old_metaclass ? $old_metaclass->name : blessed($instance); $old_class->isa( $self->name ) || confess "You may rebless only into a superclass of ($old_class), of which (" . $self->name . ") isn't."; $self->_force_rebless_instance($_[1]); return $instance; } sub rebless_instance_away { # this intentionally does nothing, it is just a hook } sub _fixup_attributes_after_rebless { my $self = shift; my ($instance, $rebless_from, %params) = @_; my $meta_instance = $self->get_meta_instance; for my $attr ( $rebless_from->get_all_attributes ) { next if $self->find_attribute_by_name( $attr->name ); $meta_instance->deinitialize_slot( $instance, $_ ) for $attr->slots; } foreach my $attr ( $self->get_all_attributes ) { if ( $attr->has_value($instance) ) { if ( defined( my $init_arg = $attr->init_arg ) ) { $params{$init_arg} = $attr->get_value($instance) unless exists $params{$init_arg}; } else { $attr->set_value($instance, $attr->get_value($instance)); } } } foreach my $attr ($self->get_all_attributes) { $attr->initialize_instance_slot($meta_instance, $instance, \%params); } } sub _attach_attribute { my ($self, $attribute) = @_; $attribute->attach_to_class($self); } sub _post_add_attribute { my ( $self, $attribute ) = @_; $self->invalidate_meta_instances; # invalidate package flag here try { local $SIG{__DIE__}; $attribute->install_accessors; } catch { $self->remove_attribute( $attribute->name ); die $_; }; } sub remove_attribute { my $self = shift; my $removed_attribute = $self->SUPER::remove_attribute(@_) or return; $self->invalidate_meta_instances; $removed_attribute->remove_accessors; $removed_attribute->detach_from_class; return$removed_attribute; } sub find_attribute_by_name { my ( $self, $attr_name ) = @_; foreach my $class ( $self->linearized_isa ) { # fetch the meta-class ... my $meta = Class::MOP::Class->initialize($class); return $meta->get_attribute($attr_name) if $meta->has_attribute($attr_name); } return; } sub get_all_attributes { my $self = shift; my %attrs = map { %{ Class::MOP::Class->initialize($_)->_attribute_map } } reverse $self->linearized_isa; return values %attrs; } # Inheritance sub superclasses { my $self = shift; my $isa = $self->get_or_add_package_symbol('@ISA'); if (@_) { my @supers = @_; @{$isa} = @supers; # NOTE: # on 5.8 and below, we need to call # a method to get Perl to detect # a cycle in the class hierarchy my $class = $self->name; $class->isa($class); # NOTE: # we need to check the metaclass # compatibility here so that we can # be sure that the superclass is # not potentially creating an issues # we don't know about $self->_check_metaclass_compatibility(); $self->_superclasses_updated(); } return @{$isa}; } sub _superclasses_updated { my $self = shift; $self->update_meta_instance_dependencies(); # keep strong references to all our parents, so they don't disappear if # they are anon classes and don't have any direct instances $self->_superclass_metas( map { Class::MOP::class_of($_) } $self->superclasses ); } sub _superclass_metas { my $self = shift; $self->{_superclass_metas} = [@_]; } sub subclasses { my $self = shift; my $super_class = $self->name; return @{ $super_class->mro::get_isarev() }; } sub direct_subclasses { my $self = shift; my $super_class = $self->name; return grep { grep { $_ eq $super_class } Class::MOP::Class->initialize($_)->superclasses } $self->subclasses; } sub linearized_isa { return @{ mro::get_linear_isa( (shift)->name ) }; } sub class_precedence_list { my $self = shift; my $name = $self->name; unless (Class::MOP::IS_RUNNING_ON_5_10()) { # NOTE: # We need to check for circular inheritance here # if we are not on 5.10, cause 5.8 detects it late. # This will do nothing if all is well, and blow up # otherwise. Yes, it's an ugly hack, better # suggestions are welcome. # - SL ($name || return)->isa('This is a test for circular inheritance') } # if our mro is c3, we can # just grab the linear_isa if (mro::get_mro($name) eq 'c3') { return @{ mro::get_linear_isa($name) } } else { # NOTE: # we can't grab the linear_isa for dfs # since it has all the duplicates # already removed. return ( $name, map { Class::MOP::Class->initialize($_)->class_precedence_list() } $self->superclasses() ); } } sub _method_lookup_order { return (shift->linearized_isa, 'UNIVERSAL'); } ## Methods { my $fetch_and_prepare_method = sub { my ($self, $method_name) = @_; my $wrapped_metaclass = $self->wrapped_method_metaclass; # fetch it locally my $method = $self->get_method($method_name); # if we don't have local ... unless ($method) { # try to find the next method $method = $self->find_next_method_by_name($method_name); # die if it does not exist (defined $method) || confess "The method '$method_name' was not found in the inheritance hierarchy for " . $self->name; # and now make sure to wrap it # even if it is already wrapped # because we need a new sub ref $method = $wrapped_metaclass->wrap($method, package_name => $self->name, name => $method_name, ); } else { # now make sure we wrap it properly $method = $wrapped_metaclass->wrap($method, package_name => $self->name, name => $method_name, ) unless $method->isa($wrapped_metaclass); } $self->add_method($method_name => $method); return $method; }; sub add_before_method_modifier { my ($self, $method_name, $method_modifier) = @_; (defined $method_name && length $method_name) || confess "You must pass in a method name"; my $method = $fetch_and_prepare_method->($self, $method_name); $method->add_before_modifier( subname(':before' => $method_modifier) ); } sub add_after_method_modifier { my ($self, $method_name, $method_modifier) = @_; (defined $method_name && length $method_name) || confess "You must pass in a method name"; my $method = $fetch_and_prepare_method->($self, $method_name); $method->add_after_modifier( subname(':after' => $method_modifier) ); } sub add_around_method_modifier { my ($self, $method_name, $method_modifier) = @_; (defined $method_name && length $method_name) || confess "You must pass in a method name"; my $method = $fetch_and_prepare_method->($self, $method_name); $method->add_around_modifier( subname(':around' => $method_modifier) ); } # NOTE: # the methods above used to be named like this: # ${pkg}::${method}:(before|after|around) # but this proved problematic when using one modifier # to wrap multiple methods (something which is likely # to happen pretty regularly IMO). So instead of naming # it like this, I have chosen to just name them purely # with their modifier names, like so: # :(before|after|around) # The fact is that in a stack trace, it will be fairly # evident from the context what method they are attached # to, and so don't need the fully qualified name. } sub find_method_by_name { my ($self, $method_name) = @_; (defined $method_name && length $method_name) || confess "You must define a method name to find"; foreach my $class ($self->_method_lookup_order) { my $method = Class::MOP::Class->initialize($class)->get_method($method_name); return $method if defined $method; } return; } sub get_all_methods { my $self = shift; my %methods; for my $class ( reverse $self->_method_lookup_order ) { my $meta = Class::MOP::Class->initialize($class); $methods{ $_->name } = $_ for $meta->_get_local_methods; } return values %methods; } sub get_all_method_names { my $self = shift; map { $_->name } $self->get_all_methods; } sub find_all_methods_by_name { my ($self, $method_name) = @_; (defined $method_name && length $method_name) || confess "You must define a method name to find"; my @methods; foreach my $class ($self->_method_lookup_order) { # fetch the meta-class ... my $meta = Class::MOP::Class->initialize($class); push @methods => { name => $method_name, class => $class, code => $meta->get_method($method_name) } if $meta->has_method($method_name); } return @methods; } sub find_next_method_by_name { my ($self, $method_name) = @_; (defined $method_name && length $method_name) || confess "You must define a method name to find"; my @cpl = ($self->_method_lookup_order); shift @cpl; # discard ourselves foreach my $class (@cpl) { my $method = Class::MOP::Class->initialize($class)->get_method($method_name); return $method if defined $method; } return; } sub update_meta_instance_dependencies { my $self = shift; if ( $self->{meta_instance_dependencies} ) { return $self->add_meta_instance_dependencies; } } sub add_meta_instance_dependencies { my $self = shift; $self->remove_meta_instance_dependencies; my @attrs = $self->get_all_attributes(); my %seen; my @classes = grep { not $seen{ $_->name }++ } map { $_->associated_class } @attrs; foreach my $class (@classes) { $class->add_dependent_meta_instance($self); } $self->{meta_instance_dependencies} = \@classes; } sub remove_meta_instance_dependencies { my $self = shift; if ( my $classes = delete $self->{meta_instance_dependencies} ) { foreach my $class (@$classes) { $class->remove_dependent_meta_instance($self); } return $classes; } return; } sub add_dependent_meta_instance { my ( $self, $metaclass ) = @_; push @{ $self->{dependent_meta_instances} }, $metaclass; } sub remove_dependent_meta_instance { my ( $self, $metaclass ) = @_; my $name = $metaclass->name; @$_ = grep { $_->name ne $name } @$_ for $self->{dependent_meta_instances}; } sub invalidate_meta_instances { my $self = shift; $_->invalidate_meta_instance() for $self, @{ $self->{dependent_meta_instances} }; } sub invalidate_meta_instance { my $self = shift; undef $self->{_meta_instance}; } # check if we can reinitialize sub is_pristine { my $self = shift; # if any local attr is defined return if $self->get_attribute_list; # or any non-declared methods for my $method ( map { $self->get_method($_) } $self->get_method_list ) { return if $method->isa("Class::MOP::Method::Generated"); # FIXME do we need to enforce this too? return unless $method->isa( $self->method_metaclass ); } return 1; } ## Class closing sub is_mutable { 1 } sub is_immutable { 0 } sub immutable_options { %{ $_[0]{__immutable}{options} || {} } } sub _immutable_options { my ( $self, @args ) = @_; return ( inline_accessors => 1, inline_constructor => 1, inline_destructor => 0, debug => 0, immutable_trait => $self->immutable_trait, constructor_name => $self->constructor_name, constructor_class => $self->constructor_class, destructor_class => $self->destructor_class, @args, ); } sub make_immutable { my ( $self, @args ) = @_; return $self unless $self->is_mutable; my ($file, $line) = (caller)[1..2]; $self->_initialize_immutable( file => $file, line => $line, $self->_immutable_options(@args), ); $self->_rebless_as_immutable(@args); return $self; } sub make_mutable { my $self = shift; if ( $self->is_immutable ) { my @args = $self->immutable_options; $self->_rebless_as_mutable(); $self->_remove_inlined_code(@args); delete $self->{__immutable}; return $self; } else { return; } } sub _rebless_as_immutable { my ( $self, @args ) = @_; $self->{__immutable}{original_class} = ref $self; bless $self => $self->_immutable_metaclass(@args); } sub _immutable_metaclass { my ( $self, %args ) = @_; if ( my $class = $args{immutable_metaclass} ) { return $class; } my $trait = $args{immutable_trait} = $self->immutable_trait || confess "no immutable trait specified for $self"; my $meta = $self->meta; my $meta_attr = $meta->find_attribute_by_name("immutable_trait"); my $class_name; if ( $meta_attr and $trait eq $meta_attr->default ) { # if the trait is the same as the default we try and pick a # predictable name for the immutable metaclass $class_name = 'Class::MOP::Class::Immutable::' . ref($self); } else { $class_name = join '::', 'Class::MOP::Class::Immutable::CustomTrait', $trait, 'ForMetaClass', ref($self); } return $class_name if is_class_loaded($class_name); # If the metaclass is a subclass of CMOP::Class which has had # metaclass roles applied (via Moose), then we want to make sure # that we preserve that anonymous class (see Fey::ORM for an # example of where this matters). my $meta_name = $meta->_real_ref_name; my $immutable_meta = $meta_name->create( $class_name, superclasses => [ ref $self ], ); Class::MOP::MiniTrait::apply( $immutable_meta, $trait ); $immutable_meta->make_immutable( inline_constructor => 0, inline_accessors => 0, ); return $class_name; } sub _remove_inlined_code { my $self = shift; $self->remove_method( $_->name ) for $self->_inlined_methods; delete $self->{__immutable}{inlined_methods}; } sub _inlined_methods { @{ $_[0]{__immutable}{inlined_methods} || [] } } sub _add_inlined_method { my ( $self, $method ) = @_; push @{ $self->{__immutable}{inlined_methods} ||= [] }, $method; } sub _initialize_immutable { my ( $self, %args ) = @_; $self->{__immutable}{options} = \%args; $self->_install_inlined_code(%args); } sub _install_inlined_code { my ( $self, %args ) = @_; # FIXME $self->_inline_accessors(%args) if $args{inline_accessors}; $self->_inline_constructor(%args) if $args{inline_constructor}; $self->_inline_destructor(%args) if $args{inline_destructor}; } sub _rebless_as_mutable { my $self = shift; bless $self, $self->_get_mutable_metaclass_name; return $self; } sub _inline_accessors { my $self = shift; foreach my $attr_name ( $self->get_attribute_list ) { $self->get_attribute($attr_name)->install_accessors(1); } } sub _inline_constructor { my ( $self, %args ) = @_; my $name = $args{constructor_name}; # A class may not even have a constructor, and that's okay. return unless defined $name; if ( $self->has_method($name) && !$args{replace_constructor} ) { my $class = $self->name; warn "Not inlining a constructor for $class since it defines" . " its own constructor.\n" . "If you are certain you don't need to inline your" . " constructor, specify inline_constructor => 0 in your" . " call to $class->meta->make_immutable\n"; return; } my $constructor_class = $args{constructor_class}; load_class($constructor_class); my $constructor = $constructor_class->new( options => \%args, metaclass => $self, is_inline => 1, package_name => $self->name, name => $name, definition_context => { description => "constructor " . $self->name . "::" . $name, file => $args{file}, line => $args{line}, }, ); if ( $args{replace_constructor} or $constructor->can_be_inlined ) { $self->add_method( $name => $constructor ); $self->_add_inlined_method($constructor); } } sub _inline_destructor { my ( $self, %args ) = @_; ( exists $args{destructor_class} && defined $args{destructor_class} ) || confess "The 'inline_destructor' option is present, but " . "no destructor class was specified"; if ( $self->has_method('DESTROY') && ! $args{replace_destructor} ) { my $class = $self->name; warn "Not inlining a destructor for $class since it defines" . " its own destructor.\n"; return; } my $destructor_class = $args{destructor_class}; load_class($destructor_class); return unless $destructor_class->is_needed($self); my $destructor = $destructor_class->new( options => \%args, metaclass => $self, package_name => $self->name, name => 'DESTROY', definition_context => { description => "destructor " . $self->name . "::DESTROY", file => $args{file}, line => $args{line}, }, ); if ( $args{replace_destructor} or $destructor->can_be_inlined ) { $self->add_method( 'DESTROY' => $destructor ); $self->_add_inlined_method($destructor); } } 1; # ABSTRACT: Class Meta Object __END__ =pod =head1 NAME Class::MOP::Class - Class Meta Object =head1 VERSION version 2.1005 =head1 SYNOPSIS # assuming that class Foo # has been defined, you can # use this for introspection ... # add a method to Foo ... Foo->meta->add_method( 'bar' => sub {...} ) # get a list of all the classes searched # the method dispatcher in the correct order Foo->meta->class_precedence_list() # remove a method from Foo Foo->meta->remove_method('bar'); # or use this to actually create classes ... Class::MOP::Class->create( 'Bar' => ( version => '0.01', superclasses => ['Foo'], attributes => [ Class::MOP::Attribute->new('$bar'), Class::MOP::Attribute->new('$baz'), ], methods => { calculate_bar => sub {...}, construct_baz => sub {...} } ) ); =head1 DESCRIPTION The Class Protocol is the largest and most complex part of the Class::MOP meta-object protocol. It controls the introspection and manipulation of Perl 5 classes, and it can create them as well. The best way to understand what this module can do is to read the documentation for each of its methods. =head1 INHERITANCE C is a subclass of L. =head1 METHODS =head2 Class construction These methods all create new C objects. These objects can represent existing classes or they can be used to create new classes from scratch. The metaclass object for a given class is a singleton. If you attempt to create a metaclass for the same class twice, you will just get the existing object. =over 4 =item B<< Class::MOP::Class->create($package_name, %options) >> This method creates a new C object with the given package name. It accepts a number of options: =over 8 =item * version An optional version number for the newly created package. =item * authority An optional authority for the newly created package. =item * superclasses An optional array reference of superclass names. =item * methods An optional hash reference of methods for the class. The keys of the hash reference are method names and values are subroutine references. =item * attributes An optional array reference of L objects. =item * meta_name Specifies the name to install the C method for this class under. If it is not passed, C is assumed, and if C is explicitly given, no meta method will be installed. =item * weaken If true, the metaclass that is stored in the global cache will be a weak reference. Classes created in this way are destroyed once the metaclass they are attached to goes out of scope, and will be removed from Perl's internal symbol table. All instances of a class with a weakened metaclass keep a special reference to the metaclass object, which prevents the metaclass from going out of scope while any instances exist. This only works if the instance is based on a hash reference, however. =back =item B<< Class::MOP::Class->create_anon_class(%options) >> This method works just like C<< Class::MOP::Class->create >> but it creates an "anonymous" class. In fact, the class does have a name, but that name is a unique name generated internally by this module. It accepts the same C, C, and C parameters that C accepts. Anonymous classes default to C<< weaken => 1 >>, although this can be overridden. =item B<< Class::MOP::Class->initialize($package_name, %options) >> This method will initialize a C object for the named package. Unlike C, this method I create a new class. The purpose of this method is to retrieve a C object for introspecting an existing class. If an existing C object exists for the named package, it will be returned, and any options provided will be ignored! If the object does not yet exist, it will be created. The valid options that can be passed to this method are C, C, C, and C. These are all optional, and default to the appropriate class in the C distribution. =back =head2 Object instance construction and cloning These methods are all related to creating and/or cloning object instances. =over 4 =item B<< $metaclass->clone_object($instance, %params) >> This method clones an existing object instance. Any parameters you provide are will override existing attribute values in the object. This is a convenience method for cloning an object instance, then blessing it into the appropriate package. You could implement a clone method in your class, using this method: sub clone { my ($self, %params) = @_; $self->meta->clone_object($self, %params); } =item B<< $metaclass->rebless_instance($instance, %params) >> This method changes the class of C<$instance> to the metaclass's class. You can only rebless an instance into a subclass of its current class. If you pass any additional parameters, these will be treated like constructor parameters and used to initialize the object's attributes. Any existing attributes that are already set will be overwritten. Before reblessing the instance, this method will call C on the instance's current metaclass. This method will be passed the instance, the new metaclass, and any parameters specified to C. By default, C does nothing; it is merely a hook. =item B<< $metaclass->rebless_instance_back($instance) >> Does the same thing as C, except that you can only rebless an instance into one of its superclasses. Any attributes that do not exist in the superclass will be deinitialized. This is a much more dangerous operation than C, especially when multiple inheritance is involved, so use this carefully! =item B<< $metaclass->new_object(%params) >> This method is used to create a new object of the metaclass's class. Any parameters you provide are used to initialize the instance's attributes. A special C<__INSTANCE__> key can be passed to provide an already generated instance, rather than having Class::MOP generate it for you. This is mostly useful for using Class::MOP with foreign classes which generate instances using their own constructors. =item B<< $metaclass->instance_metaclass >> Returns the class name of the instance metaclass. See L for more information on the instance metaclass. =item B<< $metaclass->get_meta_instance >> Returns an instance of the C to be used in the construction of a new instance of the class. =back =head2 Informational predicates These are a few predicate methods for asking information about the class itself. =over 4 =item B<< $metaclass->is_anon_class >> This returns true if the class was created by calling C<< Class::MOP::Class->create_anon_class >>. =item B<< $metaclass->is_mutable >> This returns true if the class is still mutable. =item B<< $metaclass->is_immutable >> This returns true if the class has been made immutable. =item B<< $metaclass->is_pristine >> A class is I pristine if it has non-inherited attributes or if it has any generated methods. =back =head2 Inheritance Relationships =over 4 =item B<< $metaclass->superclasses(@superclasses) >> This is a read-write accessor which represents the superclass relationships of the metaclass's class. This is basically sugar around getting and setting C<@ISA>. =item B<< $metaclass->class_precedence_list >> This returns a list of all of the class's ancestor classes. The classes are returned in method dispatch order. =item B<< $metaclass->linearized_isa >> This returns a list based on C but with all duplicates removed. =item B<< $metaclass->subclasses >> This returns a list of all subclasses for this class, even indirect subclasses. =item B<< $metaclass->direct_subclasses >> This returns a list of immediate subclasses for this class, which does not include indirect subclasses. =back =head2 Method introspection and creation These methods allow you to introspect a class's methods, as well as add, remove, or change methods. Determining what is truly a method in a Perl 5 class requires some heuristics (aka guessing). Methods defined outside the package with a fully qualified name (C) will be included. Similarly, methods named with a fully qualified name using L are also included. However, we attempt to ignore imported functions. Ultimately, we are using heuristics to determine what truly is a method in a class, and these heuristics may get the wrong answer in some edge cases. However, for most "normal" cases the heuristics work correctly. =over 4 =item B<< $metaclass->get_method($method_name) >> This will return a L for the specified C<$method_name>. If the class does not have the specified method, it returns C =item B<< $metaclass->has_method($method_name) >> Returns a boolean indicating whether or not the class defines the named method. It does not include methods inherited from parent classes. =item B<< $metaclass->get_method_list >> This will return a list of method I for all methods defined in this class. =item B<< $metaclass->add_method($method_name, $method) >> This method takes a method name and a subroutine reference, and adds the method to the class. The subroutine reference can be a L, and you are strongly encouraged to pass a meta method object instead of a code reference. If you do so, that object gets stored as part of the class's method map directly. If not, the meta information will have to be recreated later, and may be incorrect. If you provide a method object, this method will clone that object if the object's package name does not match the class name. This lets us track the original source of any methods added from other classes (notably Moose roles). =item B<< $metaclass->remove_method($method_name) >> Remove the named method from the class. This method returns the L object for the method. =item B<< $metaclass->method_metaclass >> Returns the class name of the method metaclass, see L for more information on the method metaclass. =item B<< $metaclass->wrapped_method_metaclass >> Returns the class name of the wrapped method metaclass, see L for more information on the wrapped method metaclass. =item B<< $metaclass->get_all_methods >> This will traverse the inheritance hierarchy and return a list of all the L objects for this class and its parents. =item B<< $metaclass->find_method_by_name($method_name) >> This will return a L for the specified C<$method_name>. If the class does not have the specified method, it returns C Unlike C, this method I look for the named method in superclasses. =item B<< $metaclass->get_all_method_names >> This will return a list of method I for all of this class's methods, including inherited methods. =item B<< $metaclass->find_all_methods_by_name($method_name) >> This method looks for the named method in the class and all of its parents. It returns every matching method it finds in the inheritance tree, so it returns a list of methods. Each method is returned as a hash reference with three keys. The keys are C, C, and C. The C key has a L object as its value. The list of methods is distinct. =item B<< $metaclass->find_next_method_by_name($method_name) >> This method returns the first method in any superclass matching the given name. It is effectively the method that C would dispatch to. =back =head2 Attribute introspection and creation Because Perl 5 does not have a core concept of attributes in classes, we can only return information about attributes which have been added via this class's methods. We cannot discover information about attributes which are defined in terms of "regular" Perl 5 methods. =over 4 =item B<< $metaclass->get_attribute($attribute_name) >> This will return a L for the specified C<$attribute_name>. If the class does not have the specified attribute, it returns C. NOTE that get_attribute does not search superclasses, for that you need to use C. =item B<< $metaclass->has_attribute($attribute_name) >> Returns a boolean indicating whether or not the class defines the named attribute. It does not include attributes inherited from parent classes. =item B<< $metaclass->get_attribute_list >> This will return a list of attributes I for all attributes defined in this class. Note that this operates on the current class only, it does not traverse the inheritance hierarchy. =item B<< $metaclass->get_all_attributes >> This will traverse the inheritance hierarchy and return a list of all the L objects for this class and its parents. =item B<< $metaclass->find_attribute_by_name($attribute_name) >> This will return a L for the specified C<$attribute_name>. If the class does not have the specified attribute, it returns C. Unlike C, this attribute I look for the named attribute in superclasses. =item B<< $metaclass->add_attribute(...) >> This method accepts either an existing L object or parameters suitable for passing to that class's C method. The attribute provided will be added to the class. Any accessor methods defined by the attribute will be added to the class when the attribute is added. If an attribute of the same name already exists, the old attribute will be removed first. =item B<< $metaclass->remove_attribute($attribute_name) >> This will remove the named attribute from the class, and L object. Removing an attribute also removes any accessor methods defined by the attribute. However, note that removing an attribute will only affect I object instances created for this class, not existing instances. =item B<< $metaclass->attribute_metaclass >> Returns the class name of the attribute metaclass for this class. By default, this is L. =back =head2 Overload introspection and creation These methods provide an API to the core L functionality. =over 4 =item B<< $metaclass->is_overloaded >> Returns true if overloading is enabled for this class. Corresponds to L. =item B<< $metaclass->get_overloaded_operator($op) >> Returns the L object corresponding to the operator named C<$op>, if one exists for this class. =item B<< $metaclass->has_overloaded_operator($op) >> Returns whether or not the operator C<$op> is overloaded for this class. =item B<< $metaclass->get_overload_list >> Returns a list of operator names which have been overloaded (see L for the list of valid operator names). =item B<< $metaclass->get_all_overloaded_operators >> Returns a list of L objects corresponding to the operators that have been overloaded. =item B<< $metaclass->add_overloaded_operator($op, $impl) >> Overloads the operator C<$op> for this class, with the implementation C<$impl>. C<$impl> can be either a coderef or a method name. Corresponds to C<< use overload $op => $impl; >> =item B<< $metaclass->remove_overloaded_operator($op) >> Remove overloading for operator C<$op>. Corresponds to C<< no overload $op; >> =back =head2 Class Immutability Making a class immutable "freezes" the class definition. You can no longer call methods which alter the class, such as adding or removing methods or attributes. Making a class immutable lets us optimize the class by inlining some methods, and also allows us to optimize some methods on the metaclass object itself. After immutabilization, the metaclass object will cache most informational methods that returns information about methods or attributes. Methods which would alter the class, such as C and C, will throw an error on an immutable metaclass object. The immutabilization system in L takes much greater advantage of the inlining features than Class::MOP itself does. =over 4 =item B<< $metaclass->make_immutable(%options) >> This method will create an immutable transformer and use it to make the class and its metaclass object immutable, and returns true (you should not rely on the details of this value apart from its truth). This method accepts the following options: =over 8 =item * inline_accessors =item * inline_constructor =item * inline_destructor These are all booleans indicating whether the specified method(s) should be inlined. By default, accessors and the constructor are inlined, but not the destructor. =item * immutable_trait The name of a class which will be used as a parent class for the metaclass object being made immutable. This "trait" implements the post-immutability functionality of the metaclass (but not the transformation itself). This defaults to L. =item * constructor_name This is the constructor method name. This defaults to "new". =item * constructor_class The name of the method metaclass for constructors. It will be used to generate the inlined constructor. This defaults to "Class::MOP::Method::Constructor". =item * replace_constructor This is a boolean indicating whether an existing constructor should be replaced when inlining a constructor. This defaults to false. =item * destructor_class The name of the method metaclass for destructors. It will be used to generate the inlined destructor. This defaults to "Class::MOP::Method::Denstructor". =item * replace_destructor This is a boolean indicating whether an existing destructor should be replaced when inlining a destructor. This defaults to false. =back =item B<< $metaclass->immutable_options >> Returns a hash of the options used when making the class immutable, including both defaults and anything supplied by the user in the call to C<< $metaclass->make_immutable >>. This is useful if you need to temporarily make a class mutable and then restore immutability as it was before. =item B<< $metaclass->make_mutable >> Calling this method reverse the immutabilization transformation. =back =head2 Method Modifiers Method modifiers are hooks which allow a method to be wrapped with I, I and I method modifiers. Every time a method is called, its modifiers are also called. A class can modify its own methods, as well as methods defined in parent classes. =head3 How method modifiers work? Method modifiers work by wrapping the original method and then replacing it in the class's symbol table. The wrappers will handle calling all the modifiers in the appropriate order and preserving the calling context for the original method. The return values of C and C modifiers are ignored. This is because their purpose is B to filter the input and output of the primary method (this is done with an I modifier). This may seem like an odd restriction to some, but doing this allows for simple code to be added at the beginning or end of a method call without altering the function of the wrapped method or placing any extra responsibility on the code of the modifier. Of course if you have more complex needs, you can use the C modifier which allows you to change both the parameters passed to the wrapped method, as well as its return value. Before and around modifiers are called in last-defined-first-called order, while after modifiers are called in first-defined-first-called order. So the call tree might looks something like this: before 2 before 1 around 2 around 1 primary around 1 around 2 after 1 after 2 =head3 What is the performance impact? Of course there is a performance cost associated with method modifiers, but we have made every effort to make that cost directly proportional to the number of modifier features you use. The wrapping method does its best to B do as much work as it absolutely needs to. In order to do this we have moved some of the performance costs to set-up time, where they are easier to amortize. All this said, our benchmarks have indicated the following: simple wrapper with no modifiers 100% slower simple wrapper with simple before modifier 400% slower simple wrapper with simple after modifier 450% slower simple wrapper with simple around modifier 500-550% slower simple wrapper with all 3 modifiers 1100% slower These numbers may seem daunting, but you must remember, every feature comes with some cost. To put things in perspective, just doing a simple C which does nothing but extract the name of the method called and return it costs about 400% over a normal method call. =over 4 =item B<< $metaclass->add_before_method_modifier($method_name, $code) >> This wraps the specified method with the supplied subroutine reference. The modifier will be called as a method itself, and will receive the same arguments as are passed to the method. When the modifier exits, the wrapped method will be called. The return value of the modifier will be ignored. =item B<< $metaclass->add_after_method_modifier($method_name, $code) >> This wraps the specified method with the supplied subroutine reference. The modifier will be called as a method itself, and will receive the same arguments as are passed to the method. When the wrapped methods exits, the modifier will be called. The return value of the modifier will be ignored. =item B<< $metaclass->add_around_method_modifier($method_name, $code) >> This wraps the specified method with the supplied subroutine reference. The first argument passed to the modifier will be a subroutine reference to the wrapped method. The second argument is the object, and after that come any arguments passed when the method is called. The around modifier can choose to call the original method, as well as what arguments to pass if it does so. The return value of the modifier is what will be seen by the caller. =back =head2 Introspection =over 4 =item B<< Class::MOP::Class->meta >> This will return a L instance for this class. It should also be noted that L will actually bootstrap this module by installing a number of attribute meta-objects into its metaclass. =back =head1 AUTHOR Moose is maintained by the Moose Cabal, along with the help of many contributors. See L and L for details. =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2013 by Infinity Interactive, Inc.. This is free software; you can redistribute it and/or modify it under the same terms as the Perl 5 programming language system itself. =cut Mixin.pm100644000767000024 215612200352344 16230 0ustar00etherstaff000000000000Moose-2.1005/lib/Class/MOPpackage Class::MOP::Mixin; BEGIN { $Class::MOP::Mixin::AUTHORITY = 'cpan:STEVAN'; } { $Class::MOP::Mixin::VERSION = '2.1005'; } use strict; use warnings; use Scalar::Util 'blessed'; sub meta { require Class::MOP::Class; Class::MOP::Class->initialize( blessed( $_[0] ) || $_[0] ); } 1; # ABSTRACT: Base class for mixin classes __END__ =pod =head1 NAME Class::MOP::Mixin - Base class for mixin classes =head1 VERSION version 2.1005 =head1 DESCRIPTION This class provides a single method shared by all mixins =head1 METHODS This class provides a few methods which are useful in all metaclasses. =over 4 =item B<< Class::MOP::Mixin->meta >> This returns a L object for the mixin class. =back =head1 AUTHOR Moose is maintained by the Moose Cabal, along with the help of many contributors. See L and L for details. =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2013 by Infinity Interactive, Inc.. This is free software; you can redistribute it and/or modify it under the same terms as the Perl 5 programming language system itself. =cut Cookbook.pod100644000767000024 1600312200352344 16456 0ustar00etherstaff000000000000Moose-2.1005/lib/Moosepackage Moose::Cookbook; # ABSTRACT: How to cook a Moose __END__ =pod =head1 NAME Moose::Cookbook - How to cook a Moose =head1 VERSION version 2.1005 =head1 DESCRIPTION The Moose cookbook is a series of recipes showing various Moose features. Most recipes present some code demonstrating some feature, and then explain the details of the code. You should probably read the L first. The manual explains Moose concepts without being too code-heavy. =head1 RECIPES =head2 Basic Moose These recipes will give you a good overview of Moose's capabilities, starting with simple attribute declaration, and moving on to more powerful features like laziness, types, type coercion, method modifiers, and more. =over 4 =item L A simple Moose-based class. Demonstrates basic Moose attributes and subclassing. =item L A slightly more complex Moose class. Demonstrates using a method modifier in a subclass. =item L Demonstrates several attribute features, including types, weak references, predicates ("does this object have a foo?"), defaults, laziness, and triggers. =item L Introduces the creation and use of custom types, a C method, and the use of C in a subclass. This recipe also shows how to model a set of classes that could be used to model companies, people, employees, etc. =item L This recipe covers more subtype creation, including the use of type coercions. =item L Making a class immutable greatly increases the speed of accessors and object construction. =item L - Builder methods and lazy_build The builder feature provides an inheritable and role-composable way to provide a default attribute value. =item L Demonstrates using operator overloading, coercion, and subtypes to model how eye color is determined during reproduction. =item L This recipe demonstrates the use of C and C to hook into object construction. =item L In this recipe, we make a Moose-based subclass of L, a module which does not use Moose itself. =item L Demonstrates the use of C method modifiers, a way of turning the usual method overriding style "inside-out". =back =head2 Moose Roles These recipes will show you how to use Moose roles. =over 4 =item L Demonstrates roles, which are also sometimes known as traits or mix-ins. Roles provide a method of code re-use which is orthogonal to subclassing. =item L Sometimes you just want to include part of a role in your class. Sometimes you want the whole role but one of its methods conflicts with one in your class. With method exclusion and aliasing, you can work around these problems. =item L In this recipe, we apply a role to an existing object instance. =back =head2 Meta Moose These recipes show you how to write your own meta classes, which lets you extend the object system provided by Moose. =over 4 =item L If you're wondering what all this "meta" stuff is, and why you should care about it, read this "recipe". =item L Extending Moose's attribute metaclass is a great way to add functionality. However, attributes can only have one metaclass. Applying roles to the attribute metaclass lets you provide composable attribute functionality. =item L This recipe takes the class metaclass we saw in the previous recipe and reimplements it as a metaclass trait. =item L This recipe shows a custom method metaclass that implements making a method private. =item L This recipe shows an example of how you create your own meta-instance class. The meta-instance determines the internal structure of object instances and provide access to attribute slots. In this particular instance, we use a blessed glob reference as the instance instead of a blessed hash reference. =item Hooking into immutabilization (TODO) Moose has a feature known as "immutabilization". By calling C<< __PACKAGE__->meta()->make_immutable() >> after defining your class (attributes, roles, etc), you tell Moose to optimize things like object creation, attribute access, and so on. If you are creating your own metaclasses, you may need to hook into the immutabilization system. This cuts across a number of spots, including the metaclass class, meta method classes, and possibly the meta-instance class as well. This recipe shows you how to write extensions which immutabilize properly. =back =head2 Extending Moose These recipes cover some more ways to extend Moose, and will be useful if you plan to write your own C module. =over 4 =item L There are quite a few ways to extend Moose. This recipe provides an overview of each method, and provides recommendations for when each is appropriate. =item L Many base object class extensions can be implemented as roles. This example shows how to provide a base object class debugging role that is applied to any class that uses a notional C module. =item L This recipe shows how to provide a replacement for C. You may want to do this as part of the API for a C module, especially if you want to default to a new metaclass class or base object class. =back =head1 SNACKS =over 4 =item L =item L =back =head1 Legacy Recipes These cover topics that are no longer considered best practice. We've kept them in case in you encounter these usages in the wild. =over 4 =item L =item L =item L =back =head1 SEE ALSO =over 4 =item L =back =head1 AUTHOR Moose is maintained by the Moose Cabal, along with the help of many contributors. See L and L for details. =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2013 by Infinity Interactive, Inc.. This is free software; you can redistribute it and/or modify it under the same terms as the Perl 5 programming language system itself. =cut Meta000755000767000024 012200352344 14712 5ustar00etherstaff000000000000Moose-2.1005/lib/MooseRole.pm100644000767000024 7243512200352344 16344 0ustar00etherstaff000000000000Moose-2.1005/lib/Moose/Metapackage Moose::Meta::Role; BEGIN { $Moose::Meta::Role::AUTHORITY = 'cpan:STEVAN'; } { $Moose::Meta::Role::VERSION = '2.1005'; } use strict; use warnings; use metaclass; use Class::Load qw(load_class); use Scalar::Util 'blessed'; use Carp 'confess'; use Devel::GlobalDestruction 'in_global_destruction'; use Moose::Meta::Class; use Moose::Meta::Role::Attribute; use Moose::Meta::Role::Method; use Moose::Meta::Role::Method::Required; use Moose::Meta::Role::Method::Conflicting; use Moose::Meta::Method::Meta; use Moose::Util qw( ensure_all_roles ); use Class::MOP::MiniTrait; use base 'Class::MOP::Module', 'Class::MOP::Mixin::HasAttributes', 'Class::MOP::Mixin::HasMethods'; Class::MOP::MiniTrait::apply(__PACKAGE__, 'Moose::Meta::Object::Trait'); ## ------------------------------------------------------------------ ## NOTE: ## I normally don't do this, but I am doing ## a whole bunch of meta-programmin' in this ## module, so it just makes sense. For a clearer ## picture of what is going on in the next ## several lines of code, look at the really ## big comment at the end of this file (right ## before the POD). ## - SL ## ------------------------------------------------------------------ my $META = __PACKAGE__->meta; ## ------------------------------------------------------------------ ## attributes ... # NOTE: # since roles are lazy, we hold all the attributes # of the individual role in 'stasis' until which # time when it is applied to a class. This means # keeping a lot of things in hash maps, so we are # using a little of that meta-programmin' magic # here and saving lots of extra typin'. And since # many of these attributes above require similar # functionality to support them, so we again use # the wonders of meta-programmin' to deliver a # very compact solution to this normally verbose # problem. # - SL foreach my $action ( { name => 'excluded_roles_map', attr_reader => 'get_excluded_roles_map' , methods => { add => 'add_excluded_roles', get_keys => 'get_excluded_roles_list', existence => 'excludes_role', } }, { name => 'required_methods', attr_reader => 'get_required_methods_map', methods => { remove => 'remove_required_methods', get_values => 'get_required_method_list', existence => 'requires_method', } }, ) { my $attr_reader = $action->{attr_reader}; my $methods = $action->{methods}; # create the attribute $META->add_attribute($action->{name} => ( reader => $attr_reader, default => sub { {} }, Class::MOP::_definition_context(), )); # create some helper methods $META->add_method($methods->{add} => sub { my ($self, @values) = @_; $self->$attr_reader->{$_} = undef foreach @values; }) if exists $methods->{add}; $META->add_method($methods->{get_keys} => sub { my ($self) = @_; keys %{$self->$attr_reader}; }) if exists $methods->{get_keys}; $META->add_method($methods->{get_values} => sub { my ($self) = @_; values %{$self->$attr_reader}; }) if exists $methods->{get_values}; $META->add_method($methods->{get} => sub { my ($self, $name) = @_; $self->$attr_reader->{$name} }) if exists $methods->{get}; $META->add_method($methods->{existence} => sub { my ($self, $name) = @_; exists $self->$attr_reader->{$name} ? 1 : 0; }) if exists $methods->{existence}; $META->add_method($methods->{remove} => sub { my ($self, @values) = @_; delete $self->$attr_reader->{$_} foreach @values; }) if exists $methods->{remove}; } $META->add_attribute( 'method_metaclass', reader => 'method_metaclass', default => 'Moose::Meta::Role::Method', Class::MOP::_definition_context(), ); $META->add_attribute( 'required_method_metaclass', reader => 'required_method_metaclass', default => 'Moose::Meta::Role::Method::Required', Class::MOP::_definition_context(), ); $META->add_attribute( 'conflicting_method_metaclass', reader => 'conflicting_method_metaclass', default => 'Moose::Meta::Role::Method::Conflicting', Class::MOP::_definition_context(), ); $META->add_attribute( 'application_to_class_class', reader => 'application_to_class_class', default => 'Moose::Meta::Role::Application::ToClass', Class::MOP::_definition_context(), ); $META->add_attribute( 'application_to_role_class', reader => 'application_to_role_class', default => 'Moose::Meta::Role::Application::ToRole', Class::MOP::_definition_context(), ); $META->add_attribute( 'application_to_instance_class', reader => 'application_to_instance_class', default => 'Moose::Meta::Role::Application::ToInstance', Class::MOP::_definition_context(), ); $META->add_attribute( 'applied_attribute_metaclass', reader => 'applied_attribute_metaclass', default => 'Moose::Meta::Attribute', Class::MOP::_definition_context(), ); # More or less copied from Moose::Meta::Class sub initialize { my $class = shift; my @args = @_; unshift @args, 'package' if @args % 2; my %opts = @args; my $package = delete $opts{package}; return Class::MOP::get_metaclass_by_name($package) || $class->SUPER::initialize($package, 'attribute_metaclass' => 'Moose::Meta::Role::Attribute', %opts, ); } sub reinitialize { my $self = shift; my $pkg = shift; my $meta = blessed $pkg ? $pkg : Class::MOP::class_of($pkg); my %existing_classes; if ($meta) { %existing_classes = map { $_ => $meta->$_() } qw( attribute_metaclass method_metaclass wrapped_method_metaclass required_method_metaclass conflicting_method_metaclass application_to_class_class application_to_role_class application_to_instance_class applied_attribute_metaclass ); } my %options = @_; $options{weaken} = Class::MOP::metaclass_is_weak($meta->name) if !exists $options{weaken} && blessed($meta) && $meta->isa('Moose::Meta::Role'); # don't need to remove generated metaobjects here yet, since we don't # yet generate anything in roles. this may change in the future though... # keep an eye on that my $new_meta = $self->SUPER::reinitialize( $pkg, %existing_classes, %options, ); $new_meta->_restore_metaobjects_from($meta) if $meta && $meta->isa('Moose::Meta::Role'); return $new_meta; } sub _restore_metaobjects_from { my $self = shift; my ($old_meta) = @_; $self->_restore_metamethods_from($old_meta); $self->_restore_metaattributes_from($old_meta); for my $role ( @{ $old_meta->get_roles } ) { $self->add_role($role); } } sub add_attribute { my $self = shift; if (blessed $_[0] && ! $_[0]->isa('Moose::Meta::Role::Attribute') ) { my $class = ref $_[0]; Moose->throw_error( "Cannot add a $class as an attribute to a role" ); } elsif (!blessed($_[0]) && defined($_[0]) && $_[0] =~ /^\+(.*)/) { Moose->throw_error( "has '+attr' is not supported in roles" ); } return $self->SUPER::add_attribute(@_); } sub _attach_attribute { my ( $self, $attribute ) = @_; $attribute->attach_to_role($self); } sub add_required_methods { my $self = shift; for (@_) { my $method = $_; if (!blessed($method)) { $method = $self->required_method_metaclass->new( name => $method, ); } $self->get_required_methods_map->{$method->name} = $method; } } sub add_conflicting_method { my $self = shift; my $method; if (@_ == 1 && blessed($_[0])) { $method = shift; } else { $method = $self->conflicting_method_metaclass->new(@_); } $self->add_required_methods($method); } ## ------------------------------------------------------------------ ## method modifiers # NOTE: # the before/around/after method modifiers are # stored by name, but there can be many methods # then associated with that name. So again we have # lots of similar functionality, so we can do some # meta-programmin' and save some time. # - SL foreach my $modifier_type (qw[ before around after ]) { my $attr_reader = "get_${modifier_type}_method_modifiers_map"; # create the attribute ... $META->add_attribute("${modifier_type}_method_modifiers" => ( reader => $attr_reader, default => sub { {} }, Class::MOP::_definition_context(), )); # and some helper methods ... $META->add_method("get_${modifier_type}_method_modifiers" => sub { my ($self, $method_name) = @_; #return () unless exists $self->$attr_reader->{$method_name}; my $mm = $self->$attr_reader->{$method_name}; $mm ? @$mm : (); }); $META->add_method("has_${modifier_type}_method_modifiers" => sub { my ($self, $method_name) = @_; # NOTE: # for now we assume that if it exists,.. # it has at least one modifier in it (exists $self->$attr_reader->{$method_name}) ? 1 : 0; }); $META->add_method("add_${modifier_type}_method_modifier" => sub { my ($self, $method_name, $method) = @_; $self->$attr_reader->{$method_name} = [] unless exists $self->$attr_reader->{$method_name}; my $modifiers = $self->$attr_reader->{$method_name}; # NOTE: # check to see that we aren't adding the # same code twice. We err in favor of the # first on here, this may not be as expected foreach my $modifier (@{$modifiers}) { return if $modifier == $method; } push @{$modifiers} => $method; }); } ## ------------------------------------------------------------------ ## override method modifiers $META->add_attribute('override_method_modifiers' => ( reader => 'get_override_method_modifiers_map', default => sub { {} }, Class::MOP::_definition_context(), )); # NOTE: # these are a little different because there # can only be one per name, whereas the other # method modifiers can have multiples. # - SL sub add_override_method_modifier { my ($self, $method_name, $method) = @_; (!$self->has_method($method_name)) || Moose->throw_error("Cannot add an override of method '$method_name' " . "because there is a local version of '$method_name'"); $self->get_override_method_modifiers_map->{$method_name} = $method; } sub has_override_method_modifier { my ($self, $method_name) = @_; # NOTE: # for now we assume that if it exists,.. # it has at least one modifier in it (exists $self->get_override_method_modifiers_map->{$method_name}) ? 1 : 0; } sub get_override_method_modifier { my ($self, $method_name) = @_; $self->get_override_method_modifiers_map->{$method_name}; } ## general list accessor ... sub get_method_modifier_list { my ($self, $modifier_type) = @_; my $accessor = "get_${modifier_type}_method_modifiers_map"; keys %{$self->$accessor}; } sub _meta_method_class { 'Moose::Meta::Method::Meta' } ## ------------------------------------------------------------------ ## subroles $META->add_attribute('roles' => ( reader => 'get_roles', default => sub { [] }, Class::MOP::_definition_context(), )); sub add_role { my ($self, $role) = @_; (blessed($role) && $role->isa('Moose::Meta::Role')) || Moose->throw_error("Roles must be instances of Moose::Meta::Role"); push @{$self->get_roles} => $role; $self->reset_package_cache_flag; } sub calculate_all_roles { my $self = shift; my %seen; grep { !$seen{$_->name}++ } ($self, map { $_->calculate_all_roles } @{ $self->get_roles }); } sub does_role { my ($self, $role) = @_; (defined $role) || Moose->throw_error("You must supply a role name to look for"); my $role_name = blessed $role ? $role->name : $role; # if we are it,.. then return true return 1 if $role_name eq $self->name; # otherwise.. check our children foreach my $role (@{$self->get_roles}) { return 1 if $role->does_role($role_name); } return 0; } sub find_method_by_name { (shift)->get_method(@_) } ## ------------------------------------------------------------------ ## role construction ## ------------------------------------------------------------------ sub apply { my ($self, $other, %args) = @_; (blessed($other)) || Moose->throw_error("You must pass in an blessed instance"); my $application_class; if ($other->isa('Moose::Meta::Role')) { $application_class = $self->application_to_role_class; } elsif ($other->isa('Moose::Meta::Class')) { $application_class = $self->application_to_class_class; } else { $application_class = $self->application_to_instance_class; } load_class($application_class); if ( exists $args{'-excludes'} ) { # I wish we had coercion here :) $args{'-excludes'} = ( ref $args{'-excludes'} eq 'ARRAY' ? $args{'-excludes'} : [ $args{'-excludes'} ] ); } return $application_class->new(%args)->apply($self, $other, \%args); } sub composition_class_roles { } sub combine { my ($class, @role_specs) = @_; require Moose::Meta::Role::Composite; my (@roles, %role_params); while (@role_specs) { my ($role, $params) = @{ splice @role_specs, 0, 1 }; my $requested_role = blessed $role ? $role : Class::MOP::class_of($role); my $actual_role = $requested_role->_role_for_combination($params); push @roles => $actual_role; next unless defined $params; $role_params{$actual_role->name} = $params; } my $c = Moose::Meta::Role::Composite->new(roles => \@roles); return $c->apply_params(\%role_params); } sub _role_for_combination { my ($self, $params) = @_; return $self; } sub create { my $class = shift; my @args = @_; unshift @args, 'package' if @args % 2 == 1; my %options = @args; (ref $options{attributes} eq 'HASH') || confess "You must pass a HASH ref of attributes" if exists $options{attributes}; (ref $options{methods} eq 'HASH') || confess "You must pass a HASH ref of methods" if exists $options{methods}; (ref $options{roles} eq 'ARRAY') || confess "You must pass an ARRAY ref of roles" if exists $options{roles}; my $package = delete $options{package}; my $roles = delete $options{roles}; my $attributes = delete $options{attributes}; my $methods = delete $options{methods}; my $meta_name = exists $options{meta_name} ? delete $options{meta_name} : 'meta'; my $meta = $class->SUPER::create($package => %options); $meta->_add_meta_method($meta_name) if defined $meta_name; if (defined $attributes) { foreach my $attribute_name (keys %{$attributes}) { my $attr = $attributes->{$attribute_name}; $meta->add_attribute( $attribute_name => blessed $attr ? $attr : %{$attr} ); } } if (defined $methods) { foreach my $method_name (keys %{$methods}) { $meta->add_method($method_name, $methods->{$method_name}); } } if ($roles) { Moose::Util::apply_all_roles($meta, @$roles); } return $meta; } sub consumers { my $self = shift; my @consumers; for my $meta (Class::MOP::get_all_metaclass_instances) { next if $meta->name eq $self->name; next unless $meta->isa('Moose::Meta::Class') || $meta->isa('Moose::Meta::Role'); push @consumers, $meta->name if $meta->does_role($self->name); } return @consumers; } # XXX: something more intelligent here? sub _anon_package_prefix { 'Moose::Meta::Role::__ANON__::SERIAL::' } sub create_anon_role { shift->create_anon(@_) } sub is_anon_role { shift->is_anon(@_) } sub _anon_cache_key { my $class = shift; my %options = @_; # XXX fix this duplication (see MMC::_anon_cache_key my $roles = Data::OptList::mkopt(($options{roles} || []), { moniker => 'role', val_test => sub { ref($_[0]) eq 'HASH' }, }); my @role_keys; for my $role_spec (@$roles) { my ($role, $params) = @$role_spec; $params = { %$params }; my $key = blessed($role) ? $role->name : $role; if ($params && %$params) { my $alias = delete $params->{'-alias'} || delete $params->{'alias'} || {}; my $excludes = delete $params->{'-excludes'} || delete $params->{'excludes'} || []; $excludes = [$excludes] unless ref($excludes) eq 'ARRAY'; if (%$params) { warn "Roles with parameters cannot be cached. Consider " . "applying the parameters before calling " . "create_anon_class, or using 'weaken => 0' instead"; return; } my $alias_key = join('%', map { $_ => $alias->{$_} } sort keys %$alias ); my $excludes_key = join('%', sort @$excludes ); $key .= '<' . join('+', 'a', $alias_key, 'e', $excludes_key) . '>'; } push @role_keys, $key; } # Makes something like Role|Role::1 return join('|', sort @role_keys); } ##################################################################### ## NOTE: ## This is Moose::Meta::Role as defined by Moose (plus the use of ## MooseX::AttributeHelpers module). It is here as a reference to ## make it easier to see what is happening above with all the meta ## programming. - SL ##################################################################### # # has 'roles' => ( # metaclass => 'Array', # reader => 'get_roles', # isa => 'ArrayRef[Moose::Meta::Role]', # default => sub { [] }, # provides => { # 'push' => 'add_role', # } # ); # # has 'excluded_roles_map' => ( # metaclass => 'Hash', # reader => 'get_excluded_roles_map', # isa => 'HashRef[Str]', # provides => { # # Not exactly set, cause it sets multiple # 'set' => 'add_excluded_roles', # 'keys' => 'get_excluded_roles_list', # 'exists' => 'excludes_role', # } # ); # # has 'required_methods' => ( # metaclass => 'Hash', # reader => 'get_required_methods_map', # isa => 'HashRef[Moose::Meta::Role::Method::Required]', # provides => { # # not exactly set, or delete since it works for multiple # 'set' => 'add_required_methods', # 'delete' => 'remove_required_methods', # 'keys' => 'get_required_method_list', # 'exists' => 'requires_method', # } # ); # # # the before, around and after modifiers are # # HASH keyed by method-name, with ARRAY of # # CODE refs to apply in that order # # has 'before_method_modifiers' => ( # metaclass => 'Hash', # reader => 'get_before_method_modifiers_map', # isa => 'HashRef[ArrayRef[CodeRef]]', # provides => { # 'keys' => 'get_before_method_modifiers', # 'exists' => 'has_before_method_modifiers', # # This actually makes sure there is an # # ARRAY at the given key, and pushed onto # # it. It also checks for duplicates as well # # 'add' => 'add_before_method_modifier' # } # ); # # has 'after_method_modifiers' => ( # metaclass => 'Hash', # reader =>'get_after_method_modifiers_map', # isa => 'HashRef[ArrayRef[CodeRef]]', # provides => { # 'keys' => 'get_after_method_modifiers', # 'exists' => 'has_after_method_modifiers', # # This actually makes sure there is an # # ARRAY at the given key, and pushed onto # # it. It also checks for duplicates as well # # 'add' => 'add_after_method_modifier' # } # ); # # has 'around_method_modifiers' => ( # metaclass => 'Hash', # reader =>'get_around_method_modifiers_map', # isa => 'HashRef[ArrayRef[CodeRef]]', # provides => { # 'keys' => 'get_around_method_modifiers', # 'exists' => 'has_around_method_modifiers', # # This actually makes sure there is an # # ARRAY at the given key, and pushed onto # # it. It also checks for duplicates as well # # 'add' => 'add_around_method_modifier' # } # ); # # # override is similar to the other modifiers # # except that it is not an ARRAY of code refs # # but instead just a single name->code mapping # # has 'override_method_modifiers' => ( # metaclass => 'Hash', # reader =>'get_override_method_modifiers_map', # isa => 'HashRef[CodeRef]', # provides => { # 'keys' => 'get_override_method_modifier', # 'exists' => 'has_override_method_modifier', # 'add' => 'add_override_method_modifier', # checks for local method .. # } # ); # ##################################################################### 1; # ABSTRACT: The Moose Role metaclass __END__ =pod =head1 NAME Moose::Meta::Role - The Moose Role metaclass =head1 VERSION version 2.1005 =head1 DESCRIPTION This class is a subclass of L that provides additional Moose-specific functionality. Its API looks a lot like L, but internally it implements many things differently. This may change in the future. =head1 INHERITANCE C is a subclass of L. =head1 METHODS =head2 Construction =over 4 =item B<< Moose::Meta::Role->initialize($role_name) >> This method creates a new role object with the provided name. =item B<< Moose::Meta::Role->combine( [ $role => { ... } ], [ $role ], ... ) >> This method accepts a list of array references. Each array reference should contain a role name or L object as its first element. The second element is an optional hash reference. The hash reference can contain C<-excludes> and C<-alias> keys to control how methods are composed from the role. The return value is a new L that represents the combined roles. =item B<< $metarole->composition_class_roles >> When combining multiple roles using C, this method is used to obtain a list of role names to be applied to the L instance returned by C. The default implementation returns an empty list. Extensions that need to hook into role combination may wrap this method to return additional role names. =item B<< Moose::Meta::Role->create($name, %options) >> This method is identical to the L C method. =item B<< Moose::Meta::Role->create_anon_role >> This method is identical to the L C method. =item B<< $metarole->is_anon_role >> Returns true if the role is an anonymous role. =item B<< $metarole->consumers >> Returns a list of names of classes and roles which consume this role. =back =head2 Role application =over 4 =item B<< $metarole->apply( $thing, @options ) >> This method applies a role to the given C<$thing>. That can be another L, object, a L object, or a (non-meta) object instance. The options are passed directly to the constructor for the appropriate L subclass. Note that this will apply the role even if the C<$thing> in question already C this role. L is a convenient wrapper for finding out if role application is necessary. =back =head2 Roles and other roles =over 4 =item B<< $metarole->get_roles >> This returns an array reference of roles which this role does. This list may include duplicates. =item B<< $metarole->calculate_all_roles >> This returns a I list of all roles that this role does, and all the roles that its roles do. =item B<< $metarole->does_role($role) >> Given a role I or L object, returns true if this role does the given role. =item B<< $metarole->add_role($role) >> Given a L object, this adds the role to the list of roles that the role does. =item B<< $metarole->get_excluded_roles_list >> Returns a list of role names which this role excludes. =item B<< $metarole->excludes_role($role_name) >> Given a role I, returns true if this role excludes the named role. =item B<< $metarole->add_excluded_roles(@role_names) >> Given one or more role names, adds those roles to the list of excluded roles. =back =head2 Methods The methods for dealing with a role's methods are all identical in API and behavior to the same methods in L. =over 4 =item B<< $metarole->method_metaclass >> Returns the method metaclass name for the role. This defaults to L. =item B<< $metarole->get_method($name) >> =item B<< $metarole->has_method($name) >> =item B<< $metarole->add_method( $name, $body ) >> =item B<< $metarole->get_method_list >> =item B<< $metarole->find_method_by_name($name) >> These methods are all identical to the methods of the same name in L =back =head2 Attributes As with methods, the methods for dealing with a role's attribute are all identical in API and behavior to the same methods in L. However, attributes stored in this class are I stored as objects. Rather, the attribute definition is stored as a hash reference. When a role is composed into a class, this hash reference is passed directly to the metaclass's C method. This is quite likely to change in the future. =over 4 =item B<< $metarole->get_attribute($attribute_name) >> =item B<< $metarole->has_attribute($attribute_name) >> =item B<< $metarole->get_attribute_list >> =item B<< $metarole->add_attribute($name, %options) >> =item B<< $metarole->remove_attribute($attribute_name) >> =back =head2 Overload introspection and creation The methods for dealing with a role's overloads are all identical in API and behavior to the same methods in L. Note that these are not particularly useful (yet), because overloads do not participate in role composition. =over 4 =item B<< $metarole->is_overloaded >> =item B<< $metarole->get_overloaded_operator($op) >> =item B<< $metarole->has_overloaded_operator($op) >> =item B<< $metarole->get_overload_list >> =item B<< $metarole->get_all_overloaded_operators >> =item B<< $metarole->add_overloaded_operator($op, $impl) >> =item B<< $metarole->remove_overloaded_operator($op) >> =back =head2 Required methods =over 4 =item B<< $metarole->get_required_method_list >> Returns the list of methods required by the role. =item B<< $metarole->requires_method($name) >> Returns true if the role requires the named method. =item B<< $metarole->add_required_methods(@names) >> Adds the named methods to the role's list of required methods. =item B<< $metarole->remove_required_methods(@names) >> Removes the named methods from the role's list of required methods. =item B<< $metarole->add_conflicting_method(%params) >> Instantiate the parameters as a L object, then add it to the required method list. =back =head2 Method modifiers These methods act like their counterparts in L and L. However, method modifiers are simply stored internally, and are not applied until the role itself is applied to a class. =over 4 =item B<< $metarole->add_after_method_modifier($method_name, $method) >> =item B<< $metarole->add_around_method_modifier($method_name, $method) >> =item B<< $metarole->add_before_method_modifier($method_name, $method) >> =item B<< $metarole->add_override_method_modifier($method_name, $method) >> These methods all add an appropriate modifier to the internal list of modifiers. =item B<< $metarole->has_after_method_modifiers >> =item B<< $metarole->has_around_method_modifiers >> =item B<< $metarole->has_before_method_modifiers >> =item B<< $metarole->has_override_method_modifier >> Return true if the role has any modifiers of the given type. =item B<< $metarole->get_after_method_modifiers($method_name) >> =item B<< $metarole->get_around_method_modifiers($method_name) >> =item B<< $metarole->get_before_method_modifiers($method_name) >> Given a method name, returns a list of the appropriate modifiers for that method. =item B<< $metarole->get_override_method_modifier($method_name) >> Given a method name, returns the override method modifier for that method, if it has one. =back =head2 Introspection =over 4 =item B<< Moose::Meta::Role->meta >> This will return a L instance for this class. =back =head1 BUGS See L for details on reporting bugs. =head1 AUTHOR Moose is maintained by the Moose Cabal, along with the help of many contributors. See L and L for details. =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2013 by Infinity Interactive, Inc.. This is free software; you can redistribute it and/or modify it under the same terms as the Perl 5 programming language system itself. =cut create_anon.t100644000767000024 610212200352344 16505 0ustar00etherstaff000000000000Moose-2.1005/t/basics#!/usr/bin/perl use strict; use warnings; use Test::More; use Moose::Meta::Class; { package Class; use Moose; package Foo; use Moose::Role; sub foo_role_applied { 1 } package Bar; use Moose::Role; sub bar_role_applied { 1 } } # try without caching first { my $class_and_foo_1 = Moose::Meta::Class->create_anon_class( superclasses => ['Class'], roles => ['Foo'], ); my $class_and_foo_2 = Moose::Meta::Class->create_anon_class( superclasses => ['Class'], roles => ['Foo'], ); isnt $class_and_foo_1->name, $class_and_foo_2->name, 'creating the same class twice without caching results in 2 classes'; map { ok $_->name->foo_role_applied } ($class_and_foo_1, $class_and_foo_2); } # now try with caching { my $class_and_foo_1 = Moose::Meta::Class->create_anon_class( superclasses => ['Class'], roles => ['Foo'], cache => 1, ); my $class_and_foo_2 = Moose::Meta::Class->create_anon_class( superclasses => ['Class'], roles => ['Foo'], cache => 1, ); is $class_and_foo_1->name, $class_and_foo_2->name, 'with cache, the same class is the same class'; map { ok $_->name->foo_role_applied } ($class_and_foo_1, $class_and_foo_2); my $class_and_bar = Moose::Meta::Class->create_anon_class( superclasses => ['Class'], roles => ['Bar'], cache => 1, ); isnt $class_and_foo_1->name, $class_and_bar, 'class_and_foo and class_and_bar are different'; ok $class_and_bar->name->bar_role_applied; } # This tests that a cached metaclass can be reinitialized and still retain its # metaclass object. { my $name = Moose::Meta::Class->create_anon_class( superclasses => ['Class'], cache => 1, )->name; $name->meta->reinitialize( $name ); can_ok( $name, 'meta' ); } { my $name; { my $meta = Moose::Meta::Class->create_anon_class( superclasses => ['Class'], cache => 1, ); $name = $meta->name; ok(!Class::MOP::metaclass_is_weak($name), "cache implies weaken => 0"); } ok(Class::MOP::class_of($name), "cache implies weaken => 0"); Class::MOP::remove_metaclass_by_name($name); } { my $name; { my $meta = Moose::Meta::Class->create_anon_class( superclasses => ['Class'], cache => 1, weaken => 1, ); my $name = $meta->name; ok(Class::MOP::metaclass_is_weak($name), "but we can override this"); } ok(!Class::MOP::class_of($name), "but we can override this"); } { my $meta = Moose::Meta::Class->create_anon_class( superclasses => ['Class'], cache => 1, ); ok(!Class::MOP::metaclass_is_weak($meta->name), "creates a nonweak metaclass"); Scalar::Util::weaken($meta); Class::MOP::remove_metaclass_by_name($meta->name); ok(!$meta, "removing a cached anon class means it's actually gone"); } done_testing; destruction.t100644000767000024 155512200352344 16601 0ustar00etherstaff000000000000Moose-2.1005/t/basics#!/usr/bin/perl use strict; use warnings; use Test::More; our @demolished; package Foo; use Moose; sub DEMOLISH { my $self = shift; push @::demolished, __PACKAGE__; } package Foo::Sub; use Moose; extends 'Foo'; sub DEMOLISH { my $self = shift; push @::demolished, __PACKAGE__; } package Foo::Sub::Sub; use Moose; extends 'Foo::Sub'; sub DEMOLISH { my $self = shift; push @::demolished, __PACKAGE__; } package main; { my $foo = Foo->new; } is_deeply(\@demolished, ['Foo'], "Foo demolished properly"); @demolished = (); { my $foo_sub = Foo::Sub->new; } is_deeply(\@demolished, ['Foo::Sub', 'Foo'], "Foo::Sub demolished properly"); @demolished = (); { my $foo_sub_sub = Foo::Sub::Sub->new; } is_deeply(\@demolished, ['Foo::Sub::Sub', 'Foo::Sub', 'Foo'], "Foo::Sub::Sub demolished properly"); @demolished = (); done_testing; anon_packages.t100644000767000024 147312200352344 16520 0ustar00etherstaff000000000000Moose-2.1005/t/cmop#!/usr/bin/env perl use strict; use warnings; use Test::More; use Test::Fatal; use Class::MOP; { my $name; { my $anon = Class::MOP::Package->create_anon; $name = $anon->name; $anon->add_package_symbol('&foo' => sub {}); can_ok($name, 'foo'); ok($anon->is_anon, "is anon"); } ok(!$name->can('foo'), "!$name->can('foo')"); } { my $name; { my $anon = Class::MOP::Package->create_anon(weaken => 0); $name = $anon->name; $anon->add_package_symbol('&foo' => sub {}); can_ok($name, 'foo'); ok($anon->is_anon, "is anon"); } can_ok($name, 'foo'); } { like(exception { Class::MOP::Package->create_anon(cache => 1) }, qr/^Packages are not cacheable/, "can't cache anon packages"); } done_testing; get_code_info.t100644000767000024 203712200352344 16510 0ustar00etherstaff000000000000Moose-2.1005/t/cmopuse strict; use warnings; use Test::More; use Sub::Name 'subname'; BEGIN { $^P &= ~0x200; # Don't munge anonymous sub names } use Class::MOP; sub code_name_is { my ( $code, $stash, $name ) = @_; is_deeply( [ Class::MOP::get_code_info($code) ], [ $stash, $name ], "sub name is ${stash}::$name" ); } code_name_is( sub {}, main => "__ANON__" ); code_name_is( subname("Foo::bar", sub {}), Foo => "bar" ); code_name_is( subname("", sub {}), "main" => "" ); require Class::MOP::Method; code_name_is( \&Class::MOP::Method::name, "Class::MOP::Method", "name" ); { package Foo; sub MODIFY_CODE_ATTRIBUTES { my ($class, $code) = @_; my @info = Class::MOP::get_code_info($code); if ( $] >= 5.011 ) { ::is_deeply(\@info, ['Foo', 'foo'], "got a name for a code ref in an attr handler"); } else { ::is_deeply(\@info, [], "no name for a coderef that's still compiling"); } return (); } sub foo : Bar {} } done_testing; MyMooseObject.pm100644000767000024 11712200352344 16401 0ustar00etherstaff000000000000Moose-2.1005/t/libpackage MyMooseObject; use strict; use warnings; use base 'Moose::Object'; 1;pod-spell.t100644000767000024 627012200352344 16500 0ustar00etherstaff000000000000Moose-2.1005/xt/releaseuse strict; use warnings; use Test::Spelling; my @stopwords; for () { chomp; push @stopwords, $_ unless /\A (?: \# | \s* \z)/msx; # skip comments, whitespace } add_stopwords(@stopwords); local $ENV{LC_ALL} = 'C'; set_spell_cmd('aspell list -l en'); all_pod_files_spelling_ok; __DATA__ ## personal names Aankhen Anders Aran Buels Clary Debolaz Deltac Etheridge Florian Goro Goulah Hardison Kinyon Kinyon's Kogman Lanyon Luehrs McWhirter Pearcey Piotr Prather Ragwitz Reis Rockway Roditi Rolsky Roszatycki Roszatycki's SL Sedlacek Shlomi Stevan Vilain Yuval autarch backported backports blblack bluefeet chansen chromatic's dexter doy ewilhelm frodwith gphat groditi ingy jgoulah jrockway kolibrie konobi lbr merlyn mst nothingmuch perigrin phaylon rafl rindolf rlb robkinyon sartak stevan tozt wreis ## proper names AOP CentOS CLOS CPAN OCaml SVN ohloh ## Moose AttributeHelpers BUILDALL BUILDARGS BankAccount BankAccount's BinaryTree CLR CheckingAccount DEMOLISHALL Debuggable JVM METACLASS Metaclass MOPs MetaModel MetaObject Metalevel MooseX Num OtherName PosInt PositiveInt RoleSummation Specio Str TypeContraints clearers composable hardcode immutabilization immutabilize introspectable metaclass metaclass's metadata metaobject metaobjects metaprogrammer metarole metaroles metatraits mixins oose ro rw ## computerese API APIs Baz Changelog Coercions DUCKTYPE DWIM GitHub GitHub's Haskell IRC Immutabilization Inlinable JSON Lexically O'Caml OO OOP ORM ROLETYPE SUBCLASSES SUBTYPES Subclasses Smalltalk Subtypes TODO UNIMPORTING URI Unported Whitelist # from the Support manual talking about version numbers YY YYZZ ZZ arity arrayrefs autodelegation blog clearers codebase coercions committer committers compat continutation contrib datetimes dec decrement definedness deinitialized deprecations destructor destructors destructuring dev discoverable env eval'ing extensibility hashrefs hotspots immutabilize immutabilized immutabilizes incrementing inlinable inline inlines installable instantiation interoperable invocant invocant's irc isa kv login matcher metadata mixin mixins mul munge namespace Namespace namespace's namespaced namespaces namespacing natatime # as in required-ness ness optimizations overridable parameterizable parameterization parameterize parameterized parameterizes params pluggable plugins polymorphism prechecking prepends pu rebase rebased rebasing rebless reblesses reblessing refactored refactoring rethrows runtime serializer sigil sigils stacktrace stacktraces stateful subclass's subclassable subclasses subname subtype subtypes subtyping unblessed unexport unimporting uninitialize unordered unresolvable unsets unsettable utils whitelisted workflow workflows ## other jargon bey gey ## neologisms breakability delegatee featureful hackery hacktern undeprecate wrappee ## compound # half-assed assed # role-ish, Ruby-ish, medium-to-large-ish ish # kool-aid kool # pre-5.10 pre # vice versa versa lookup # co-maint maint ## slang C'mon might've Nuff ## things that should be in the dictionary, but are not attribute's declaratively everybody's everyone's human's indices initializers newfound reimplements reinitializes specializer unintrusive ## misspelt on purpose emali uniq Conflicts.pm100644000767000024 535712200352344 16460 0ustar00etherstaff000000000000Moose-2.1005/lib/Moosepackage # hide from PAUSE Moose::Conflicts; use strict; use warnings; use Dist::CheckConflicts -dist => 'Moose', -conflicts => { 'Catalyst' => '5.80028', 'Devel::REPL' => '1.003008', 'Fey' => '0.36', 'Fey::ORM' => '0.42', 'File::ChangeNotify' => '0.15', 'KiokuDB' => '0.51', 'Markdent' => '0.16', 'Mason' => '2.18', 'MooseX::ABC' => '0.05', 'MooseX::Aliases' => '0.08', 'MooseX::AlwaysCoerce' => '0.13', 'MooseX::App' => '1.18', 'MooseX::Attribute::Deflator' => '2.1.7', 'MooseX::Attribute::Dependent' => '1.1.0', 'MooseX::Attribute::Prototype' => '0.10', 'MooseX::AttributeHelpers' => '0.22', 'MooseX::AttributeIndexes' => '1.0.0', 'MooseX::AttributeInflate' => '0.02', 'MooseX::CascadeClearing' => '0.03', 'MooseX::ClassAttribute' => '0.26', 'MooseX::Constructor::AllErrors' => '0.012', 'MooseX::FollowPBP' => '0.02', 'MooseX::HasDefaults' => '0.02', 'MooseX::InstanceTracking' => '0.04', 'MooseX::LazyRequire' => '0.06', 'MooseX::Meta::Attribute::Index' => '0.04', 'MooseX::Meta::Attribute::Lvalue' => '0.05', 'MooseX::MethodAttributes' => '0.22', 'MooseX::NonMoose' => '0.17', 'MooseX::POE' => '0.214', 'MooseX::Params::Validate' => '0.05', 'MooseX::PrivateSetters' => '0.03', 'MooseX::Role::Cmd' => '0.06', 'MooseX::Role::Parameterized' => '0.23', 'MooseX::Role::WithOverloading' => '0.07', 'MooseX::Scaffold' => '0.05', 'MooseX::SemiAffordanceAccessor' => '0.05', 'MooseX::SetOnce' => '0.100473', 'MooseX::Singleton' => '0.25', 'MooseX::SlurpyConstructor' => '1.1', 'MooseX::StrictConstructor' => '0.12', 'MooseX::Types' => '0.19', 'MooseX::Types::Parameterizable' => '0.05', 'MooseX::Types::Signal' => '1.101930', 'MooseX::UndefTolerant' => '0.11', 'PRANG' => '0.14', 'Pod::Elemental' => '0.093280', 'Reaction' => '0.002003', 'Test::Able' => '0.10', 'namespace::autoclean' => '0.08', }, ; 1; # ABSTRACT: Provide information on conflicts for Moose __END__ =pod =head1 NAME Moose::Conflicts - Provide information on conflicts for Moose =head1 VERSION version 2.1005 =head1 AUTHOR Moose is maintained by the Moose Cabal, along with the help of many contributors. See L and L for details. =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2013 by Infinity Interactive, Inc.. This is free software; you can redistribute it and/or modify it under the same terms as the Perl 5 programming language system itself. =cut benchmarks000755000767000024 012200352344 14311 5ustar00etherstaff000000000000Moose-2.1005immutable.pl100600000767000024 445212200352344 16762 0ustar00etherstaff000000000000Moose-2.1005/benchmarks#!/usr/bin/perl use strict; use warnings; use Scalar::Util 'blessed'; use Benchmark qw[cmpthese]; use Moose::Util::TypeConstraints; { package Foo; use Moose; Foo->meta->make_immutable(debug => 0); } coerce 'Foo' => from 'ArrayRef' => via { Foo->new(@{$_}) }; { package Foo::Normal; use Moose; has 'default' => (is => 'rw', default => 10); has 'default_sub' => (is => 'rw', default => sub { [] }); has 'lazy' => (is => 'rw', default => 10, lazy => 1); has 'required' => (is => 'rw', required => 1); has 'weak_ref' => (is => 'rw', weak_ref => 1); has 'type_constraint' => (is => 'rw', isa => 'Foo'); has 'coercion' => (is => 'rw', isa => 'Foo', coerce => 1); package Bar::Normal; use Moose; extends 'Foo::Normal'; has 'default_w_type_constraint' => ( is => 'rw', isa => 'Int', default => 10, ); } { package Foo::Immutable; use Moose; has 'default' => (is => 'rw', default => 10); has 'default_sub' => (is => 'rw', default => sub { [] }); has 'lazy' => (is => 'rw', default => 10, lazy => 1); has 'required' => (is => 'rw', required => 1); has 'weak_ref' => (is => 'rw', weak_ref => 1); has 'type_constraint' => (is => 'rw', isa => 'Foo'); has 'coercion' => (is => 'rw', isa => 'Foo', coerce => 1); #sub BUILD { # # ... #} Foo::Immutable->meta->make_immutable(debug => 0); package Bar::Immutable; use Moose; extends 'Foo::Immutable'; has 'default_w_type_constraint' => ( is => 'rw', isa => 'Int', default => 10, ); Bar::Immutable->meta->make_immutable(debug => 0); } #__END__ my $foo = Foo->new; cmpthese(10_000, { 'normal' => sub { Foo::Normal->new( required => 'BAR', type_constraint => $foo, coercion => [], weak_ref => {}, ); }, 'immutable' => sub { Foo::Immutable->new( required => 'BAR', type_constraint => $foo, coercion => [], weak_ref => {}, ); }, } );all.yml100644000767000024 112412200352344 16700 0ustar00etherstaff000000000000Moose-2.1005/benchmarks/cmop--- - name: Point classes classes: - 'MOP::Point' - 'MOP::Point3D' - 'MOP::Immutable::Point' - 'MOP::Immutable::Point3D' - 'MOP::Installed::Point' - 'MOP::Installed::Point3D' - 'Plain::Point' - 'Plain::Point3D' benchmarks: - class: 'Bench::Construct' name: object construction args: y: 137 - class: 'Bench::Accessor' name: accessor get construct: x: 4 y: 6 accessor: x - class: 'Bench::Accessor' name: accessor set construct: x: 4 y: 6 accessor: x accessor_args: [ 5 ] Method.pm100644000767000024 1645212200352344 16410 0ustar00etherstaff000000000000Moose-2.1005/lib/Class/MOP package Class::MOP::Method; BEGIN { $Class::MOP::Method::AUTHORITY = 'cpan:STEVAN'; } { $Class::MOP::Method::VERSION = '2.1005'; } use strict; use warnings; use Carp 'confess'; use Scalar::Util 'weaken', 'reftype', 'blessed'; use base 'Class::MOP::Object'; # NOTE: # if poked in the right way, # they should act like CODE refs. use overload '&{}' => sub { $_[0]->body }, fallback => 1; # construction sub wrap { my ( $class, @args ) = @_; unshift @args, 'body' if @args % 2 == 1; my %params = @args; my $code = $params{body}; if (blessed($code) && $code->isa(__PACKAGE__)) { my $method = $code->clone; delete $params{body}; Class::MOP::class_of($class)->rebless_instance($method, %params); return $method; } elsif (!ref $code || 'CODE' ne reftype($code)) { confess "You must supply a CODE reference to bless, not (" . ($code || 'undef') . ")"; } ($params{package_name} && $params{name}) || confess "You must supply the package_name and name parameters"; my $self = $class->_new(\%params); weaken($self->{associated_metaclass}) if $self->{associated_metaclass}; return $self; } sub _new { my $class = shift; return Class::MOP::Class->initialize($class)->new_object(@_) if $class ne __PACKAGE__; my $params = @_ == 1 ? $_[0] : {@_}; return bless { 'body' => $params->{body}, 'associated_metaclass' => $params->{associated_metaclass}, 'package_name' => $params->{package_name}, 'name' => $params->{name}, 'original_method' => $params->{original_method}, } => $class; } ## accessors sub associated_metaclass { shift->{'associated_metaclass'} } sub attach_to_class { my ( $self, $class ) = @_; $self->{associated_metaclass} = $class; weaken($self->{associated_metaclass}); } sub detach_from_class { my $self = shift; delete $self->{associated_metaclass}; } sub fully_qualified_name { my $self = shift; $self->package_name . '::' . $self->name; } sub original_method { (shift)->{'original_method'} } sub _set_original_method { $_[0]->{'original_method'} = $_[1] } # It's possible that this could cause a loop if there is a circular # reference in here. That shouldn't ever happen in normal # circumstances, since original method only gets set when clone is # called. We _could_ check for such a loop, but it'd involve some sort # of package-lexical variable, and wouldn't be terribly subclassable. sub original_package_name { my $self = shift; $self->original_method ? $self->original_method->original_package_name : $self->package_name; } sub original_name { my $self = shift; $self->original_method ? $self->original_method->original_name : $self->name; } sub original_fully_qualified_name { my $self = shift; $self->original_method ? $self->original_method->original_fully_qualified_name : $self->fully_qualified_name; } sub execute { my $self = shift; $self->body->(@_); } # We used to go through use Class::MOP::Class->clone_instance to do this, but # this was awfully slow. This method may be called a number of times when # classes are loaded (especially during Moose role application), so it is # worth optimizing. - DR sub clone { my $self = shift; my $clone = bless { %{$self}, @_ }, blessed($self); weaken($clone->{associated_metaclass}) if $clone->{associated_metaclass}; $clone->_set_original_method($self); return $clone; } 1; # ABSTRACT: Method Meta Object __END__ =pod =head1 NAME Class::MOP::Method - Method Meta Object =head1 VERSION version 2.1005 =head1 DESCRIPTION The Method Protocol is very small, since methods in Perl 5 are just subroutines in a specific package. We provide a very basic introspection interface. =head1 METHODS =over 4 =item B<< Class::MOP::Method->wrap($code, %options) >> This is the constructor. It accepts a method body in the form of either a code reference or a L instance, followed by a hash of options. The options are: =over 8 =item * name The method name (without a package name). This is required if C<$code> is a coderef. =item * package_name The package name for the method. This is required if C<$code> is a coderef. =item * associated_metaclass An optional L object. This is the metaclass for the method's class. =back =item B<< $metamethod->clone(%params) >> This makes a shallow clone of the method object. In particular, subroutine reference itself is shared between all clones of a given method. When a method is cloned, the original method object will be available by calling C on the clone. =item B<< $metamethod->body >> This returns a reference to the method's subroutine. =item B<< $metamethod->name >> This returns the method's name =item B<< $metamethod->package_name >> This returns the method's package name. =item B<< $metamethod->fully_qualified_name >> This returns the method's fully qualified name (package name and method name). =item B<< $metamethod->associated_metaclass >> This returns the L object for the method, if one exists. =item B<< $metamethod->original_method >> If this method object was created as a clone of some other method object, this returns the object that was cloned. =item B<< $metamethod->original_name >> This returns the method's original name, wherever it was first defined. If this method is a clone of a clone (of a clone, etc.), this method returns the name from the I method in the chain of clones. =item B<< $metamethod->original_package_name >> This returns the method's original package name, wherever it was first defined. If this method is a clone of a clone (of a clone, etc.), this method returns the package name from the I method in the chain of clones. =item B<< $metamethod->original_fully_qualified_name >> This returns the method's original fully qualified name, wherever it was first defined. If this method is a clone of a clone (of a clone, etc.), this method returns the fully qualified name from the I method in the chain of clones. =item B<< $metamethod->is_stub >> Returns true if the method is just a stub: sub foo; =item B<< $metamethod->attach_to_class($metaclass) >> Given a L object, this method sets the associated metaclass for the method. This will overwrite any existing associated metaclass. =item B<< $metamethod->detach_from_class >> Removes any associated metaclass object for the method. =item B<< $metamethod->execute(...) >> This executes the method. Any arguments provided will be passed on to the method itself. =item B<< Class::MOP::Method->meta >> This will return a L instance for this class. It should also be noted that L will actually bootstrap this module by installing a number of attribute meta-objects into its metaclass. =back =head1 AUTHOR Moose is maintained by the Moose Cabal, along with the help of many contributors. See L and L for details. =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2013 by Infinity Interactive, Inc.. This is free software; you can redistribute it and/or modify it under the same terms as the Perl 5 programming language system itself. =cut Module.pm100644000767000024 673612200352344 16401 0ustar00etherstaff000000000000Moose-2.1005/lib/Class/MOP package Class::MOP::Module; BEGIN { $Class::MOP::Module::AUTHORITY = 'cpan:STEVAN'; } { $Class::MOP::Module::VERSION = '2.1005'; } use strict; use warnings; use Carp 'confess'; use Scalar::Util 'blessed'; use base 'Class::MOP::Package'; sub _new { my $class = shift; return Class::MOP::Class->initialize($class)->new_object(@_) if $class ne __PACKAGE__; my $params = @_ == 1 ? $_[0] : {@_}; return bless { # Need to quote package to avoid a problem with PPI mis-parsing this # as a package statement. # from Class::MOP::Package 'package' => $params->{package}, namespace => \undef, # attributes version => \undef, authority => \undef } => $class; } sub version { my $self = shift; ${$self->get_or_add_package_symbol('$VERSION')}; } sub authority { my $self = shift; ${$self->get_or_add_package_symbol('$AUTHORITY')}; } sub identifier { my $self = shift; join '-' => ( $self->name, ($self->version || ()), ($self->authority || ()), ); } sub create { my $class = shift; my @args = @_; unshift @args, 'package' if @args % 2 == 1; my %options = @args; my $package = delete $options{package}; my $version = delete $options{version}; my $authority = delete $options{authority}; my $meta = $class->SUPER::create($package => %options); $meta->_instantiate_module($version, $authority); return $meta; } sub _anon_package_prefix { 'Class::MOP::Module::__ANON__::SERIAL::' } sub _anon_cache_key { confess "Modules are not cacheable" } sub _instantiate_module { my($self, $version, $authority) = @_; my $package_name = $self->name; $self->add_package_symbol('$VERSION' => $version) if defined $version; $self->add_package_symbol('$AUTHORITY' => $authority) if defined $authority; return; } 1; # ABSTRACT: Module Meta Object __END__ =pod =head1 NAME Class::MOP::Module - Module Meta Object =head1 VERSION version 2.1005 =head1 DESCRIPTION A module is essentially a L with metadata, in our case the version and authority. =head1 INHERITANCE B is a subclass of L. =head1 METHODS =over 4 =item B<< Class::MOP::Module->create($package, %options) >> Overrides C from L to provide these additional options: =over 4 =item C A version number, to be installed in the C<$VERSION> package global variable. =item C An authority, to be installed in the C<$AUTHORITY> package global variable. =back =item B<< $metamodule->version >> This is a read-only attribute which returns the C<$VERSION> of the package, if one exists. =item B<< $metamodule->authority >> This is a read-only attribute which returns the C<$AUTHORITY> of the package, if one exists. =item B<< $metamodule->identifier >> This constructs a string which combines the name, version and authority. =item B<< Class::MOP::Module->meta >> This will return a L instance for this class. =back =head1 AUTHOR Moose is maintained by the Moose Cabal, along with the help of many contributors. See L and L for details. =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2013 by Infinity Interactive, Inc.. This is free software; you can redistribute it and/or modify it under the same terms as the Perl 5 programming language system itself. =cut Object.pm100644000767000024 605512200352344 16354 0ustar00etherstaff000000000000Moose-2.1005/lib/Class/MOP package Class::MOP::Object; BEGIN { $Class::MOP::Object::AUTHORITY = 'cpan:STEVAN'; } { $Class::MOP::Object::VERSION = '2.1005'; } use strict; use warnings; use Carp qw(confess); use Scalar::Util 'blessed'; # introspection sub meta { require Class::MOP::Class; Class::MOP::Class->initialize(blessed($_[0]) || $_[0]); } sub _new { Class::MOP::class_of(shift)->new_object(@_); } # RANT: # Cmon, how many times have you written # the following code while debugging: # # use Data::Dumper; # warn Dumper $obj; # # It can get seriously annoying, so why # not just do this ... sub dump { my $self = shift; require Data::Dumper; local $Data::Dumper::Maxdepth = shift || 1; Data::Dumper::Dumper $self; } sub _real_ref_name { my $self = shift; return blessed($self); } sub _is_compatible_with { my $self = shift; my ($other_name) = @_; return $self->isa($other_name); } sub _can_be_made_compatible_with { my $self = shift; return !$self->_is_compatible_with(@_) && defined($self->_get_compatible_metaclass(@_)); } sub _make_compatible_with { my $self = shift; my ($other_name) = @_; my $new_metaclass = $self->_get_compatible_metaclass($other_name); confess "Can't make $self compatible with metaclass $other_name" unless defined $new_metaclass; # can't use rebless_instance here, because it might not be an actual # subclass in the case of, e.g. moose role reconciliation $new_metaclass->meta->_force_rebless_instance($self) if blessed($self) ne $new_metaclass; return $self; } sub _get_compatible_metaclass { my $self = shift; my ($other_name) = @_; return $self->_get_compatible_metaclass_by_subclassing($other_name); } sub _get_compatible_metaclass_by_subclassing { my $self = shift; my ($other_name) = @_; my $meta_name = blessed($self) ? $self->_real_ref_name : $self; if ($meta_name->isa($other_name)) { return $meta_name; } elsif ($other_name->isa($meta_name)) { return $other_name; } return; } 1; # ABSTRACT: Base class for metaclasses __END__ =pod =head1 NAME Class::MOP::Object - Base class for metaclasses =head1 VERSION version 2.1005 =head1 DESCRIPTION This class is a very minimal base class for metaclasses. =head1 METHODS This class provides a few methods which are useful in all metaclasses. =over 4 =item B<< Class::MOP::???->meta >> This returns a L object. =item B<< $metaobject->dump($max_depth) >> This method uses L to dump the object. You can pass an optional maximum depth, which will set C<$Data::Dumper::Maxdepth>. The default maximum depth is 1. =back =head1 AUTHOR Moose is maintained by the Moose Cabal, along with the help of many contributors. See L and L for details. =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2013 by Infinity Interactive, Inc.. This is free software; you can redistribute it and/or modify it under the same terms as the Perl 5 programming language system itself. =cut Deprecated.pm100644000767000024 262712200352344 16571 0ustar00etherstaff000000000000Moose-2.1005/lib/Moosepackage Moose::Deprecated; BEGIN { $Moose::Deprecated::AUTHORITY = 'cpan:STEVAN'; } { $Moose::Deprecated::VERSION = '2.1005'; } use strict; use warnings; use Package::DeprecationManager 0.07 -deprecations => { 'optimized type constraint sub ref' => '2.0000', 'default is for Native Trait' => '1.14', 'default default for Native Trait' => '1.14', 'coerce without coercion' => '1.08', }, -ignore => [qr/^(?:Class::MOP|Moose)(?:::)?/], ; 1; # ABSTRACT: Manages deprecation warnings for Moose __END__ =pod =head1 NAME Moose::Deprecated - Manages deprecation warnings for Moose =head1 VERSION version 2.1005 =head1 DESCRIPTION use Moose::Deprecated -api_version => $version; =head1 FUNCTIONS This module manages deprecation warnings for features that have been deprecated in Moose. If you specify C<< -api_version => $version >>, you can use deprecated features without warnings. Note that this special treatment is limited to the package that loads C. =head1 AUTHOR Moose is maintained by the Moose Cabal, along with the help of many contributors. See L and L for details. =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2013 by Infinity Interactive, Inc.. This is free software; you can redistribute it and/or modify it under the same terms as the Perl 5 programming language system itself. =cut Error000755000767000024 012200352344 15115 5ustar00etherstaff000000000000Moose-2.1005/lib/MooseUtil.pm100644000767000024 216312200352344 16532 0ustar00etherstaff000000000000Moose-2.1005/lib/Moose/Errorpackage # pretend this doesn't exist, because it shouldn't Moose::Error::Util; use strict; use warnings; # this intentionally exists to have a place to put this logic that doesn't # involve loading Class::MOP, so... don't do that use Carp::Heavy; sub _create_error_carpmess { my %args = @_; my $carp_level = 3 + ( $args{depth} || 0 ); local $Carp::MaxArgNums = 20; # default is 8, usually we use named args which gets messier though my @args = exists $args{message} ? $args{message} : (); if ( $args{longmess} || $Carp::Verbose ) { local $Carp::CarpLevel = ( $Carp::CarpLevel || 0 ) + $carp_level; return Carp::longmess(@args); } else { return Carp::ret_summary($carp_level, @args); } } sub create_error_croak { _create_error_carpmess(@_); } sub create_error_confess { _create_error_carpmess(@_, longmess => 1); } sub create_error { if (defined $ENV{MOOSE_ERROR_STYLE} && $ENV{MOOSE_ERROR_STYLE} eq 'croak') { create_error_croak(@_); } else { create_error_confess(@_); } } 1; __END__ =pod =for pod_coverage_needs_some_pod =cut Class.pm100644000767000024 7317112200352344 16506 0ustar00etherstaff000000000000Moose-2.1005/lib/Moose/Meta package Moose::Meta::Class; BEGIN { $Moose::Meta::Class::AUTHORITY = 'cpan:STEVAN'; } { $Moose::Meta::Class::VERSION = '2.1005'; } use strict; use warnings; use Class::Load qw(load_class); use Class::MOP; use Carp qw( confess ); use Data::OptList; use List::Util qw( first ); use List::MoreUtils qw( any all uniq first_index ); use Scalar::Util 'blessed'; use Moose::Meta::Method::Overridden; use Moose::Meta::Method::Augmented; use Moose::Error::Default; use Moose::Meta::Class::Immutable::Trait; use Moose::Meta::Method::Constructor; use Moose::Meta::Method::Destructor; use Moose::Meta::Method::Meta; use Moose::Util; use Class::MOP::MiniTrait; use base 'Class::MOP::Class'; Class::MOP::MiniTrait::apply(__PACKAGE__, 'Moose::Meta::Object::Trait'); __PACKAGE__->meta->add_attribute('roles' => ( reader => 'roles', default => sub { [] }, Class::MOP::_definition_context(), )); __PACKAGE__->meta->add_attribute('role_applications' => ( reader => '_get_role_applications', default => sub { [] }, Class::MOP::_definition_context(), )); __PACKAGE__->meta->add_attribute( Class::MOP::Attribute->new('immutable_trait' => ( accessor => "immutable_trait", default => 'Moose::Meta::Class::Immutable::Trait', Class::MOP::_definition_context(), )) ); __PACKAGE__->meta->add_attribute('constructor_class' => ( accessor => 'constructor_class', default => 'Moose::Meta::Method::Constructor', Class::MOP::_definition_context(), )); __PACKAGE__->meta->add_attribute('destructor_class' => ( accessor => 'destructor_class', default => 'Moose::Meta::Method::Destructor', Class::MOP::_definition_context(), )); __PACKAGE__->meta->add_attribute('error_class' => ( accessor => 'error_class', default => 'Moose::Error::Default', Class::MOP::_definition_context(), )); sub initialize { my $class = shift; my @args = @_; unshift @args, 'package' if @args % 2; my %opts = @args; my $package = delete $opts{package}; return Class::MOP::get_metaclass_by_name($package) || $class->SUPER::initialize($package, 'attribute_metaclass' => 'Moose::Meta::Attribute', 'method_metaclass' => 'Moose::Meta::Method', 'instance_metaclass' => 'Moose::Meta::Instance', %opts, ); } sub create { my $class = shift; my @args = @_; unshift @args, 'package' if @args % 2 == 1; my %options = @args; (ref $options{roles} eq 'ARRAY') || $class->throw_error("You must pass an ARRAY ref of roles", data => $options{roles}) if exists $options{roles}; my $package = delete $options{package}; my $roles = delete $options{roles}; my $new_meta = $class->SUPER::create($package, %options); if ($roles) { Moose::Util::apply_all_roles( $new_meta, @$roles ); } return $new_meta; } sub _meta_method_class { 'Moose::Meta::Method::Meta' } sub _anon_package_prefix { 'Moose::Meta::Class::__ANON__::SERIAL::' } sub _anon_cache_key { my $class = shift; my %options = @_; my $superclass_key = join('|', map { $_->[0] } @{ Data::OptList::mkopt($options{superclasses} || []) } ); my $roles = Data::OptList::mkopt(($options{roles} || []), { moniker => 'role', val_test => sub { ref($_[0]) eq 'HASH' }, }); my @role_keys; for my $role_spec (@$roles) { my ($role, $params) = @$role_spec; $params = { %$params } if $params; my $key = blessed($role) ? $role->name : $role; if ($params && %$params) { my $alias = delete $params->{'-alias'} || delete $params->{'alias'} || {}; my $excludes = delete $params->{'-excludes'} || delete $params->{'excludes'} || []; $excludes = [$excludes] unless ref($excludes) eq 'ARRAY'; if (%$params) { warn "Roles with parameters cannot be cached. Consider " . "applying the parameters before calling " . "create_anon_class, or using 'weaken => 0' instead"; return; } my $alias_key = join('%', map { $_ => $alias->{$_} } sort keys %$alias ); my $excludes_key = join('%', sort @$excludes ); $key .= '<' . join('+', 'a', $alias_key, 'e', $excludes_key) . '>'; } push @role_keys, $key; } my $role_key = join('|', sort @role_keys); # Makes something like Super::Class|Super::Class::2=Role|Role::1 return join('=', $superclass_key, $role_key); } sub reinitialize { my $self = shift; my $pkg = shift; my $meta = blessed $pkg ? $pkg : Class::MOP::class_of($pkg); my %existing_classes; if ($meta) { %existing_classes = map { $_ => $meta->$_() } qw( attribute_metaclass method_metaclass wrapped_method_metaclass instance_metaclass constructor_class destructor_class error_class ); } return $self->SUPER::reinitialize( $pkg, %existing_classes, @_, ); } sub add_role { my ($self, $role) = @_; (blessed($role) && $role->isa('Moose::Meta::Role')) || $self->throw_error("Roles must be instances of Moose::Meta::Role", data => $role); push @{$self->roles} => $role; } sub role_applications { my ($self) = @_; return @{$self->_get_role_applications}; } sub add_role_application { my ($self, $application) = @_; (blessed($application) && $application->isa('Moose::Meta::Role::Application::ToClass')) || $self->throw_error("Role applications must be instances of Moose::Meta::Role::Application::ToClass", data => $application); push @{$self->_get_role_applications} => $application; } sub calculate_all_roles { my $self = shift; my %seen; grep { !$seen{$_->name}++ } map { $_->calculate_all_roles } @{ $self->roles }; } sub _roles_with_inheritance { my $self = shift; my %seen; grep { !$seen{$_->name}++ } map { Class::MOP::class_of($_)->can('roles') ? @{ Class::MOP::class_of($_)->roles } : () } $self->linearized_isa; } sub calculate_all_roles_with_inheritance { my $self = shift; my %seen; grep { !$seen{$_->name}++ } map { Class::MOP::class_of($_)->can('calculate_all_roles') ? Class::MOP::class_of($_)->calculate_all_roles : () } $self->linearized_isa; } sub does_role { my ($self, $role_name) = @_; (defined $role_name) || $self->throw_error("You must supply a role name to look for"); foreach my $class ($self->class_precedence_list) { my $meta = Class::MOP::class_of($class); # when a Moose metaclass is itself extended with a role, # this check needs to be done since some items in the # class_precedence_list might in fact be Class::MOP # based still. next unless $meta && $meta->can('roles'); foreach my $role (@{$meta->roles}) { return 1 if $role->does_role($role_name); } } return 0; } sub excludes_role { my ($self, $role_name) = @_; (defined $role_name) || $self->throw_error("You must supply a role name to look for"); foreach my $class ($self->class_precedence_list) { my $meta = Class::MOP::class_of($class); # when a Moose metaclass is itself extended with a role, # this check needs to be done since some items in the # class_precedence_list might in fact be Class::MOP # based still. next unless $meta && $meta->can('roles'); foreach my $role (@{$meta->roles}) { return 1 if $role->excludes_role($role_name); } } return 0; } sub new_object { my $self = shift; my $params = @_ == 1 ? $_[0] : {@_}; my $object = $self->SUPER::new_object($params); $self->_call_all_triggers($object, $params); $object->BUILDALL($params) if $object->can('BUILDALL'); return $object; } sub _call_all_triggers { my ($self, $object, $params) = @_; foreach my $attr ( $self->get_all_attributes() ) { next unless $attr->can('has_trigger') && $attr->has_trigger; my $init_arg = $attr->init_arg; next unless defined $init_arg; next unless exists $params->{$init_arg}; $attr->trigger->( $object, ( $attr->should_coerce ? $attr->get_read_method_ref->($object) : $params->{$init_arg} ), ); } } sub _generate_fallback_constructor { my $self = shift; my ($class) = @_; return $class . '->Moose::Object::new(@_)' } sub _inline_params { my $self = shift; my ($params, $class) = @_; return ( 'my ' . $params . ' = ', $self->_inline_BUILDARGS($class, '@_'), ';', ); } sub _inline_BUILDARGS { my $self = shift; my ($class, $args) = @_; my $buildargs = $self->find_method_by_name("BUILDARGS"); if ($args eq '@_' && (!$buildargs or $buildargs->body == \&Moose::Object::BUILDARGS)) { return ( 'do {', 'my $params;', 'if (scalar @_ == 1) {', 'if (!defined($_[0]) || ref($_[0]) ne \'HASH\') {', $self->_inline_throw_error( '"Single parameters to new() must be a HASH ref"', 'data => $_[0]', ) . ';', '}', '$params = { %{ $_[0] } };', '}', 'elsif (@_ % 2) {', 'Carp::carp(', '"The new() method for ' . $class . ' expects a ' . 'hash reference or a key/value list. You passed an ' . 'odd number of arguments"', ');', '$params = {@_, undef};', '}', 'else {', '$params = {@_};', '}', '$params;', '}', ); } else { return $class . '->BUILDARGS(' . $args . ')'; } } sub _inline_slot_initializer { my $self = shift; my ($attr, $idx) = @_; return ( '## ' . $attr->name, $self->_inline_check_required_attr($attr), $self->SUPER::_inline_slot_initializer(@_), ); } sub _inline_check_required_attr { my $self = shift; my ($attr) = @_; return unless defined $attr->init_arg; return unless $attr->can('is_required') && $attr->is_required; return if $attr->has_default || $attr->has_builder; return ( 'if (!exists $params->{\'' . $attr->init_arg . '\'}) {', $self->_inline_throw_error( '"Attribute (' . quotemeta($attr->name) . ') is required"' ) . ';', '}', ); } # XXX: these two are duplicated from cmop, because we have to pass the tc stuff # through to _inline_set_value - this should probably be fixed, but i'm not # quite sure how. -doy sub _inline_init_attr_from_constructor { my $self = shift; my ($attr, $idx) = @_; my @initial_value = $attr->_inline_set_value( '$instance', '$params->{\'' . $attr->init_arg . '\'}', '$type_constraint_bodies[' . $idx . ']', '$type_coercions[' . $idx . ']', '$type_constraint_messages[' . $idx . ']', 'for constructor', ); push @initial_value, ( '$attrs->[' . $idx . ']->set_initial_value(', '$instance,', $attr->_inline_instance_get('$instance'), ');', ) if $attr->has_initializer; return @initial_value; } sub _inline_init_attr_from_default { my $self = shift; my ($attr, $idx) = @_; return if $attr->can('is_lazy') && $attr->is_lazy; my $default = $self->_inline_default_value($attr, $idx); return unless $default; my @initial_value = ( 'my $default = ' . $default . ';', $attr->_inline_set_value( '$instance', '$default', '$type_constraint_bodies[' . $idx . ']', '$type_coercions[' . $idx . ']', '$type_constraint_messages[' . $idx . ']', 'for constructor', ), ); push @initial_value, ( '$attrs->[' . $idx . ']->set_initial_value(', '$instance,', $attr->_inline_instance_get('$instance'), ');', ) if $attr->has_initializer; return @initial_value; } sub _inline_extra_init { my $self = shift; return ( $self->_inline_triggers, $self->_inline_BUILDALL, ); } sub _inline_triggers { my $self = shift; my @trigger_calls; my @attrs = sort { $a->name cmp $b->name } $self->get_all_attributes; for my $i (0 .. $#attrs) { my $attr = $attrs[$i]; next unless $attr->can('has_trigger') && $attr->has_trigger; my $init_arg = $attr->init_arg; next unless defined $init_arg; push @trigger_calls, 'if (exists $params->{\'' . $init_arg . '\'}) {', '$triggers->[' . $i . ']->(', '$instance,', $attr->_inline_instance_get('$instance') . ',', ');', '}'; } return @trigger_calls; } sub _inline_BUILDALL { my $self = shift; my @methods = reverse $self->find_all_methods_by_name('BUILD'); my @BUILD_calls; foreach my $method (@methods) { push @BUILD_calls, '$instance->' . $method->{class} . '::BUILD($params);'; } return @BUILD_calls; } sub _eval_environment { my $self = shift; my @attrs = sort { $a->name cmp $b->name } $self->get_all_attributes; my $triggers = [ map { $_->can('has_trigger') && $_->has_trigger ? $_->trigger : undef } @attrs ]; # We need to check if the attribute ->can('type_constraint') # since we may be trying to immutabilize a Moose meta class, # which in turn has attributes which are Class::MOP::Attribute # objects, rather than Moose::Meta::Attribute. And # Class::MOP::Attribute attributes have no type constraints. # However we need to make sure we leave an undef value there # because the inlined code is using the index of the attributes # to determine where to find the type constraint my @type_constraints = map { $_->can('type_constraint') ? $_->type_constraint : undef } @attrs; my @type_constraint_bodies = map { defined $_ ? $_->_compiled_type_constraint : undef; } @type_constraints; my @type_coercions = map { defined $_ && $_->has_coercion ? $_->coercion->_compiled_type_coercion : undef } @type_constraints; my @type_constraint_messages = map { defined $_ ? ($_->has_message ? $_->message : $_->_default_message) : undef } @type_constraints; return { %{ $self->SUPER::_eval_environment }, ((any { defined && $_->has_initializer } @attrs) ? ('$attrs' => \[@attrs]) : ()), '$triggers' => \$triggers, '@type_coercions' => \@type_coercions, '@type_constraint_bodies' => \@type_constraint_bodies, '@type_constraint_messages' => \@type_constraint_messages, ( map { defined($_) ? %{ $_->inline_environment } : () } @type_constraints ), # pretty sure this is only going to be closed over if you use a custom # error class at this point, but we should still get rid of this # at some point '$meta' => \$self, }; } sub superclasses { my $self = shift; my $supers = Data::OptList::mkopt(\@_); foreach my $super (@{ $supers }) { my ($name, $opts) = @{ $super }; load_class($name, $opts); my $meta = Class::MOP::class_of($name); $self->throw_error("You cannot inherit from a Moose Role ($name)") if $meta && $meta->isa('Moose::Meta::Role') } return $self->SUPER::superclasses(map { $_->[0] } @{ $supers }); } ### --------------------------------------------- sub add_attribute { my $self = shift; my $attr = (blessed $_[0] && $_[0]->isa('Class::MOP::Attribute') ? $_[0] : $self->_process_attribute(@_)); $self->SUPER::add_attribute($attr); # it may be a Class::MOP::Attribute, theoretically, which doesn't have # 'bare' and doesn't implement this method if ($attr->can('_check_associated_methods')) { $attr->_check_associated_methods; } return $attr; } sub add_override_method_modifier { my ($self, $name, $method, $_super_package) = @_; (!$self->has_method($name)) || $self->throw_error("Cannot add an override method if a local method is already present"); $self->add_method($name => Moose::Meta::Method::Overridden->new( method => $method, class => $self, package => $_super_package, # need this for roles name => $name, )); } sub add_augment_method_modifier { my ($self, $name, $method) = @_; (!$self->has_method($name)) || $self->throw_error("Cannot add an augment method if a local method is already present"); $self->add_method($name => Moose::Meta::Method::Augmented->new( method => $method, class => $self, name => $name, )); } ## Private Utility methods ... sub _find_next_method_by_name_which_is_not_overridden { my ($self, $name) = @_; foreach my $method ($self->find_all_methods_by_name($name)) { return $method->{code} if blessed($method->{code}) && !$method->{code}->isa('Moose::Meta::Method::Overridden'); } return undef; } ## Metaclass compatibility sub _base_metaclasses { my $self = shift; my %metaclasses = $self->SUPER::_base_metaclasses; for my $class (keys %metaclasses) { $metaclasses{$class} =~ s/^Class::MOP/Moose::Meta/; } return ( %metaclasses, error_class => 'Moose::Error::Default', ); } sub _fix_class_metaclass_incompatibility { my $self = shift; my ($super_meta) = @_; $self->SUPER::_fix_class_metaclass_incompatibility(@_); if ($self->_class_metaclass_can_be_made_compatible($super_meta)) { ($self->is_pristine) || confess "Can't fix metaclass incompatibility for " . $self->name . " because it is not pristine."; my $super_meta_name = $super_meta->_real_ref_name; my $class_meta_subclass_meta_name = Moose::Util::_reconcile_roles_for_metaclass(blessed($self), $super_meta_name); my $new_self = $class_meta_subclass_meta_name->reinitialize( $self->name, ); $self->_replace_self( $new_self, $class_meta_subclass_meta_name ); } } sub _fix_single_metaclass_incompatibility { my $self = shift; my ($metaclass_type, $super_meta) = @_; $self->SUPER::_fix_single_metaclass_incompatibility(@_); if ($self->_single_metaclass_can_be_made_compatible($super_meta, $metaclass_type)) { ($self->is_pristine) || confess "Can't fix metaclass incompatibility for " . $self->name . " because it is not pristine."; my $super_meta_name = $super_meta->_real_ref_name; my $class_specific_meta_subclass_meta_name = Moose::Util::_reconcile_roles_for_metaclass($self->$metaclass_type, $super_meta->$metaclass_type); my $new_self = $super_meta->reinitialize( $self->name, $metaclass_type => $class_specific_meta_subclass_meta_name, ); $self->_replace_self( $new_self, $super_meta_name ); } } sub _replace_self { my $self = shift; my ( $new_self, $new_class) = @_; %$self = %$new_self; bless $self, $new_class; # We need to replace the cached metaclass instance or else when it goes # out of scope Class::MOP::Class destroy's the namespace for the # metaclass's class, causing much havoc. my $weaken = Class::MOP::metaclass_is_weak( $self->name ); Class::MOP::store_metaclass_by_name( $self->name, $self ); Class::MOP::weaken_metaclass( $self->name ) if $weaken; } sub _process_attribute { my ( $self, $name, @args ) = @_; @args = %{$args[0]} if scalar @args == 1 && ref($args[0]) eq 'HASH'; if (($name || '') =~ /^\+(.*)/) { return $self->_process_inherited_attribute($1, @args); } else { return $self->_process_new_attribute($name, @args); } } sub _process_new_attribute { my ( $self, $name, @args ) = @_; $self->attribute_metaclass->interpolate_class_and_new($name, @args); } sub _process_inherited_attribute { my ($self, $attr_name, %options) = @_; my $inherited_attr = $self->find_attribute_by_name($attr_name); (defined $inherited_attr) || $self->throw_error("Could not find an attribute by the name of '$attr_name' to inherit from in ${\$self->name}", data => $attr_name); if ($inherited_attr->isa('Moose::Meta::Attribute')) { return $inherited_attr->clone_and_inherit_options(%options); } else { # NOTE: # kind of a kludge to handle Class::MOP::Attributes return $inherited_attr->Moose::Meta::Attribute::clone_and_inherit_options(%options); } } # reinitialization support sub _restore_metaobjects_from { my $self = shift; my ($old_meta) = @_; $self->SUPER::_restore_metaobjects_from($old_meta); for my $role ( @{ $old_meta->roles } ) { $self->add_role($role); } for my $application ( @{ $old_meta->_get_role_applications } ) { $application->class($self); $self->add_role_application ($application); } } ## Immutability sub _immutable_options { my ( $self, @args ) = @_; $self->SUPER::_immutable_options( inline_destructor => 1, # Moose always does this when an attribute is created inline_accessors => 0, @args, ); } sub _fixup_attributes_after_rebless { my $self = shift; my ($instance, $rebless_from, %params) = @_; $self->SUPER::_fixup_attributes_after_rebless( $instance, $rebless_from, %params ); $self->_call_all_triggers( $instance, \%params ); } ## ------------------------------------------------- our $error_level; sub throw_error { my ( $self, @args ) = @_; local $error_level = ($error_level || 0) + 1; $self->raise_error($self->create_error(@args)); } sub _inline_throw_error { my ( $self, @args ) = @_; $self->_inline_raise_error($self->_inline_create_error(@args)); } sub raise_error { my ( $self, @args ) = @_; die @args; } sub _inline_raise_error { my ( $self, $message ) = @_; return 'die ' . $message; } sub create_error { my ( $self, @args ) = @_; require Carp::Heavy; local $error_level = ($error_level || 0 ) + 1; if ( @args % 2 == 1 ) { unshift @args, "message"; } my %args = ( metaclass => $self, last_error => $@, @args ); $args{depth} += $error_level; my $class = ref $self ? $self->error_class : "Moose::Error::Default"; load_class($class); $class->new( Carp::caller_info($args{depth}), %args ); } sub _inline_create_error { my ( $self, $msg, $args ) = @_; # XXX ignore $args for now, nothing currently uses it anyway require Carp::Heavy; my %args = ( metaclass => $self, last_error => $@, message => $msg, ); my $class = ref $self ? $self->error_class : "Moose::Error::Default"; load_class($class); # don't check inheritance here - the intention is that the class needs # to provide a non-inherited inlining method, because falling back to # the default inlining method is most likely going to be wrong # yes, this is a huge hack, but so is the entire error system, so. return '$meta->create_error(' . $msg . ( defined $args ? ', ' . $args : q{} ) . ');' unless $class->meta->has_method('_inline_new'); $class->_inline_new( # XXX ignore this for now too # Carp::caller_info($args{depth}), %args ); } 1; # ABSTRACT: The Moose metaclass __END__ =pod =head1 NAME Moose::Meta::Class - The Moose metaclass =head1 VERSION version 2.1005 =head1 DESCRIPTION This class is a subclass of L that provides additional Moose-specific functionality. To really understand this class, you will need to start with the L documentation. This class can be understood as a set of additional features on top of the basic feature provided by that parent class. =head1 INHERITANCE C is a subclass of L. =head1 METHODS =over 4 =item B<< Moose::Meta::Class->initialize($package_name, %options) >> This overrides the parent's method in order to provide its own defaults for the C, C, and C options. These all default to the appropriate Moose class. =item B<< Moose::Meta::Class->create($package_name, %options) >> This overrides the parent's method in order to accept a C option. This should be an array reference containing roles that the class does, each optionally followed by a hashref of options (C<-excludes> and C<-alias>). my $metaclass = Moose::Meta::Class->create( 'New::Class', roles => [...] ); =item B<< Moose::Meta::Class->create_anon_class >> This overrides the parent's method to accept a C option, just as C does. It also accepts a C option. If this is true, then the anonymous class will be cached based on its superclasses and roles. If an existing anonymous class in the cache has the same superclasses and roles, it will be reused. my $metaclass = Moose::Meta::Class->create_anon_class( superclasses => ['Foo'], roles => [qw/Some Roles Go Here/], cache => 1, ); Each entry in both the C and the C option can be followed by a hash reference with arguments. The C option can be supplied with a L<-version|Class::MOP/Class Loading Options> option that ensures the loaded superclass satisfies the required version. The C option also takes the C<-version> as an argument, but the option hash reference can also contain any other role relevant values like exclusions or parameterized role arguments. =item B<< $metaclass->new_object(%params) >> This overrides the parent's method in order to add support for attribute triggers. =item B<< $metaclass->superclasses(@superclasses) >> This is the accessor allowing you to read or change the parents of the class. Each superclass can be followed by a hash reference containing a L<-version|Class::MOP/Class Loading Options> value. If the version requirement is not satisfied an error will be thrown. =item B<< $metaclass->add_override_method_modifier($name, $sub) >> This adds an C method modifier to the package. =item B<< $metaclass->add_augment_method_modifier($name, $sub) >> This adds an C method modifier to the package. =item B<< $metaclass->calculate_all_roles >> This will return a unique array of C instances which are attached to this class. =item B<< $metaclass->calculate_all_roles_with_inheritance >> This will return a unique array of C instances which are attached to this class, and each of this class's ancestors. =item B<< $metaclass->add_role($role) >> This takes a L object, and adds it to the class's list of roles. This I actually apply the role to the class. =item B<< $metaclass->role_applications >> Returns a list of L objects, which contain the arguments to role application. =item B<< $metaclass->add_role_application($application) >> This takes a L object, and adds it to the class's list of role applications. This I actually apply any role to the class; it is only for tracking role applications. =item B<< $metaclass->does_role($role) >> This returns a boolean indicating whether or not the class does the specified role. The role provided can be either a role name or a L object. This tests both the class and its parents. =item B<< $metaclass->excludes_role($role_name) >> A class excludes a role if it has already composed a role which excludes the named role. This tests both the class and its parents. =item B<< $metaclass->add_attribute($attr_name, %params|$params) >> This overrides the parent's method in order to allow the parameters to be provided as a hash reference. =item B<< $metaclass->constructor_class($class_name) >> =item B<< $metaclass->destructor_class($class_name) >> These are the names of classes used when making a class immutable. These default to L and L respectively. These accessors are read-write, so you can use them to change the class name. =item B<< $metaclass->error_class($class_name) >> The name of the class used to throw errors. This defaults to L, which generates an error with a stacktrace just like C. =item B<< $metaclass->throw_error($message, %extra) >> Throws the error created by C using C =back =head1 BUGS See L for details on reporting bugs. =head1 AUTHOR Moose is maintained by the Moose Cabal, along with the help of many contributors. See L and L for details. =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2013 by Infinity Interactive, Inc.. This is free software; you can redistribute it and/or modify it under the same terms as the Perl 5 programming language system itself. =cut Spec000755000767000024 012200352344 14716 5ustar00etherstaff000000000000Moose-2.1005/lib/MooseRole.pod100644000767000024 2214612200352344 16510 0ustar00etherstaff000000000000Moose-2.1005/lib/Moose/Specpackage Moose::Spec::Role; # ABSTRACT: Formal spec for Role behavior __END__ =pod =head1 NAME Moose::Spec::Role - Formal spec for Role behavior =head1 VERSION version 2.1005 =head1 DESCRIPTION B This document is currently incomplete. =head2 Components of a Role =over 4 =item Excluded Roles A role can have a list of excluded roles, these are basically roles that they shouldn't be composed with. This is not just direct composition either, but also "inherited" composition. This feature was taken from the Fortress language and is really of most use when building a large set of role "building blocks" some of which should never be used together. =item Attributes A roles attributes are similar to those of a class, except that they are not actually applied. This means that methods that are generated by an attributes accessor will not be generated in the role, but only created once the role is applied to a class. =item Methods These are the methods defined within the role. Simple as that. =item Required Methods A role can require a consuming class (or role) to provide a given method. Failure to do so for classes is a fatal error, while for roles it simply passes on the method requirement to the consuming role. =item Required Attributes Just as a role can require methods, it can also require attributes. The requirement fulfilling attribute must implement at least as much as is required. That means, for instance, that if the role requires that the attribute be read-only, then it must at least have a reader and can also have a writer. It means that if the role requires that the attribute be an ArrayRef, then it must either be an ArrayRef or a subtype of an ArrayRef. =item Overridden Methods The C and C keywords are allowed in roles, but their behavior is different from that of its class counterparts. The C in a class refers directly to that class's superclass, while the C in a role is deferred and only has meaning once the role is composed into a class. Once that composition occurs, C then refers to that class's superclass. It is key to remember that roles do not have hierarchy, so they can never have a I role. =item Method Modifiers These are the C, C and C modifiers provided in Moose classes. The difference here is that the modifiers are not actually applied until the role is composed into a class (this is just like attributes and the C keyword). =back =head2 Role Composition =head3 Composing into a Class =over 4 =item Excluded Roles =item Required Methods =item Required Attributes =item Attributes =item Methods =item Overridden methods =item Method Modifiers (before, around, after) =back =head3 Composing into a Instance =head3 Composing into a Role =over 4 =item Excluded Roles =item Required Methods =item Required Attributes =item Attributes =item Methods =item Overridden methods =item Method Modifiers (before, around, after) =back =head3 Role Summation When multiple roles are added to another role (using the C keyword) the roles are composed symmetrically. The product of the composition is a composite role (L). =over 4 =item Excluded Roles =item Required Methods =item Required Attributes =item Attributes Attributes with the same name will conflict and are considered a unrecoverable error. No other aspect of the attribute is examined, it is enough that just the attribute names conflict. The reason for such early and harsh conflicts with attributes is because there is so much room for variance between two attributes that the problem quickly explodes and rules get very complex. It is my opinion that this complexity is not worth the trouble. =item Methods Methods with the same name will conflict, but no error is thrown, instead the method name is added to the list of I methods for the new composite role. To look at this in terms of set theory, each role can be said to have a set of methods. The symmetric difference of these two sets is the new set of methods for the composite role, while the intersection of these two sets are the conflicts. This can be illustrated like so: Role A has method set { a, b, c } Role B has method set { c, d, e } The composite role (A,B) has method set { a, b, d, e } conflict set { c } =item Overridden methods An overridden method can conflict in one of two ways. The first way is with another overridden method of the same name, and this is considered an unrecoverable error. This is an obvious error since you cannot override a method twice in the same class. The second way for conflict is for an overridden method and a regular method to have the same name. This is also an unrecoverable error since there is no way to combine these two, nor is it okay for both items to be composed into a single class at some point. The use of override in roles can be tricky, but if used carefully they can be a very powerful tool. =item Method Modifiers (before, around, after) Method modifiers are the only place where the ordering of role composition matters. This is due to the nature of method modifiers themselves. Since a method can have multiple method modifiers, these are just collected in order to be later applied to the class in that same order. In general, great care should be taken in using method modifiers in roles. The order sensitivity can possibly lead to subtle and difficult to find bugs if they are overused. As with all good things in life, moderation is the key. =back =head3 Composition Edge Cases This is a just a set of complex edge cases which can easily get confused. This attempts to clarify those cases and provide an explanation of what is going on in them. =over 4 =item Role Method Overriding Many people want to "override" methods in roles they are consuming. This works fine for classes, since the local class method is favored over the role method. However in roles it is trickier, this is because conflicts result in neither method being chosen and the method being "required" instead. Here is an example of this (incorrect) type of overriding. package Role::Foo; use Moose::Role; sub foo { ... } package Role::FooBar; use Moose::Role; with 'Role::Foo'; sub foo { ... } sub bar { ... } Here the C methods conflict and the Role::FooBar now requires a class or role consuming it to implement C. This is very often not what the user wants. Now here is an example of the (correct) type of overriding, only it is not overriding at all, as is explained in the text below. package Role::Foo; use Moose::Role; sub foo { ... } package Role::Bar; use Moose::Role; sub foo { ... } sub bar { ... } package Role::FooBar; use Moose::Role; with 'Role::Foo', 'Role::Bar'; sub foo { ... } This works because the combination of Role::Foo and Role::Bar produce a conflict with the C method. This conflict results in the composite role (that was created by the combination of Role::Foo and Role::Bar using the I keyword) having a method requirement of C. The Role::FooBar then fulfills this requirement. It is important to note that Role::FooBar is simply fulfilling the required C method, and **NOT** overriding C. This is an important distinction to make. Now here is another example of a (correct) type of overriding, this time using the I option. package Role::Foo; use Moose::Role; sub foo { ... } package Role::FooBar; use Moose::Role; with 'Role::Foo' => { -excludes => 'foo' }; sub foo { ... } sub bar { ... } By specifically excluding the C method during composition, we allow B to define its own version of C. =back =head1 SEE ALSO =over 4 =item Traits Roles are based on Traits, which originated in the Smalltalk community. =over 4 =item L This is the main site for the original Traits papers. =item L I created this implementation of traits several years ago, after reading the papers linked above. (This module is now maintained by Ovid and I am no longer involved with it). =back =item Roles Since they are relatively new, and the Moose implementation is probably the most mature out there, roles don't have much to link to. However, here is some bits worth looking at (mostly related to Perl 6) =over 4 =item L This is chromatic's take on roles, which is worth reading since he was/is one of the big proponents of them. =item L This is Synopsis 12, which is all about the Perl 6 Object System. Which, of course, includes roles. =back =back =head1 AUTHOR Moose is maintained by the Moose Cabal, along with the help of many contributors. See L and L for details. =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2013 by Infinity Interactive, Inc.. This is free software; you can redistribute it and/or modify it under the same terms as the Perl 5 programming language system itself. =cut deprecations.t100644000767000024 1101312200352344 16724 0ustar00etherstaff000000000000Moose-2.1005/t/basicsuse strict; use warnings; use Test::Fatal; use Test::More; use Test::Requires { 'Test::Output' => '0.01', }; # All tests are wrapped with lives_and because the stderr output tests will # otherwise eat exceptions, and the test just dies silently. { package Role; use Moose::Role; sub thing { } } { package Foo; use Moose; ::is( ::exception ( sub { ::stderr_like{ has foo => ( traits => ['String'], is => 'ro', isa => 'Str', ); } qr{\QAllowing a native trait to automatically supply a default is deprecated. You can avoid this warning by supplying a default, builder, or making the attribute required at $0 line}, 'Not providing a default for native String trait warns'; ::stderr_is{ has bar => ( traits => ['Bool'], isa => 'Bool', default => q{}, ); } q{}, 'No warning when _default_is is set'; ::stderr_like{ Foo->new->bar } qr{\QThe bar method in the Foo class was automatically created by the native delegation trait for the bar attribute. This "default is" feature is deprecated. Explicitly set "is" or define accessor names to avoid this at $0 line}, 'calling a reader on a method created by a _default_is warns'; } ), undef ); } { package Pack1; use Moose; ::is( ::exception ( sub { ::stderr_is{ has foo => ( traits => ['String'], is => 'ro', isa => 'Str', builder => '_build_foo', ); } q{}, 'Providing a builder for a String trait avoids default default warning'; has bar => ( traits => ['String'], reader => '_bar', isa => 'Str', default => q{}, ); ::ok( !Pack1->can('bar'), 'no default is assigned when reader is provided' ); ::stderr_is{ Pack1->new->_bar } q{}, 'Providing a reader for a String trait avoids default is warning'; } ), undef ); sub _build_foo { q{} } } { package Pack2; use Moose; ::is( ::exception ( sub { ::stderr_is{ has foo => ( traits => ['String'], is => 'ro', isa => 'Str', required => 1, ); } q{}, 'Making a String trait required avoids default default warning'; has bar => ( traits => ['String'], writer => '_bar', isa => 'Str', default => q{}, ); ::ok( !Pack2->can('bar'), 'no default is assigned when writer is provided' ); ::stderr_is{ Pack2->new( foo => 'x' )->_bar('x') } q{}, 'Providing a writer for a String trait avoids default is warning'; } ), undef ); } { package Pack3; use Moose; ::is( ::exception ( sub { ::stderr_is{ has foo => ( traits => ['String'], is => 'ro', isa => 'Str', lazy_build => 1, ); } q{}, 'Making a String trait lazy_build avoids default default warning'; has bar => ( traits => ['String'], accessor => '_bar', isa => 'Str', default => q{}, ); ::ok( !Pack3->can('bar'), 'no default is assigned when accessor is provided' ); ::stderr_is{ Pack3->new->_bar } q{}, 'Providing a accessor for a String trait avoids default is warning'; } ), undef ); sub _build_foo { q{} } } { use Moose::Util::TypeConstraints; is( exception { stderr_like { subtype 'Frubble', as 'Str', optimize_as sub { }; } qr/\QProviding an optimized subroutine ref for type constraints is deprecated./, 'Providing an optimize_as sub is deprecated'; }, undef ); } done_testing; LazyClass_test.t100644000767000024 525212200352344 16672 0ustar00etherstaff000000000000Moose-2.1005/t/cmopuse strict; use warnings; use Test::More; use File::Spec; use Class::MOP; BEGIN { require_ok(File::Spec->catfile('examples', 'LazyClass.pod')); } { package BinaryTree; use metaclass ( 'attribute_metaclass' => 'LazyClass::Attribute', 'instance_metaclass' => 'LazyClass::Instance', ); BinaryTree->meta->add_attribute('node' => ( accessor => 'node', init_arg => 'node' )); BinaryTree->meta->add_attribute('left' => ( reader => 'left', default => sub { BinaryTree->new() } )); BinaryTree->meta->add_attribute('right' => ( reader => 'right', default => sub { BinaryTree->new() } )); sub new { my $class = shift; bless $class->meta->new_object(@_) => $class; } } my $root = BinaryTree->new('node' => 0); isa_ok($root, 'BinaryTree'); ok(exists($root->{'node'}), '... node attribute has been initialized yet'); ok(!exists($root->{'left'}), '... left attribute has not been initialized yet'); ok(!exists($root->{'right'}), '... right attribute has not been initialized yet'); isa_ok($root->left, 'BinaryTree'); isa_ok($root->right, 'BinaryTree'); ok(exists($root->{'left'}), '... left attribute has now been initialized'); ok(exists($root->{'right'}), '... right attribute has now been initialized'); ok(!exists($root->left->{'node'}), '... node attribute has not been initialized yet'); ok(!exists($root->left->{'left'}), '... left attribute has not been initialized yet'); ok(!exists($root->left->{'right'}), '... right attribute has not been initialized yet'); ok(!exists($root->right->{'node'}), '... node attribute has not been initialized yet'); ok(!exists($root->right->{'left'}), '... left attribute has not been initialized yet'); ok(!exists($root->right->{'right'}), '... right attribute has not been initialized yet'); is($root->left->node(), undef, '... the left node is uninitialized'); ok(exists($root->left->{'node'}), '... node attribute has now been initialized'); $root->left->node(1); is($root->left->node(), 1, '... the left node == 1'); ok(!exists($root->left->{'left'}), '... left attribute still has not been initialized yet'); ok(!exists($root->left->{'right'}), '... right attribute still has not been initialized yet'); is($root->right->node(), undef, '... the right node is uninitialized'); ok(exists($root->right->{'node'}), '... node attribute has now been initialized'); $root->right->node(2); is($root->right->node(), 2, '... the right node == 1'); ok(!exists($root->right->{'left'}), '... left attribute still has not been initialized yet'); ok(!exists($root->right->{'right'}), '... right attribute still has not been initialized yet'); done_testing; immutable000755000767000024 012200352344 14416 5ustar00etherstaff000000000000Moose-2.1005/tbuildargs.t100644000767000024 167512200352344 16730 0ustar00etherstaff000000000000Moose-2.1005/t/immutable#!/usr/bin/perl use strict; use warnings; use Test::More; { package Foo; use Moose; has bar => ( is => "rw" ); has baz => ( is => "rw" ); sub BUILDARGS { my ( $self, @args ) = @_; unshift @args, "bar" if @args % 2 == 1; return {@args}; } __PACKAGE__->meta->make_immutable; package Bar; use Moose; extends qw(Foo); __PACKAGE__->meta->make_immutable; } foreach my $class (qw(Foo Bar)) { is( $class->new->bar, undef, "no args" ); is( $class->new( bar => 42 )->bar, 42, "normal args" ); is( $class->new( 37 )->bar, 37, "single arg" ); { my $o = $class->new(bar => 42, baz => 47); is($o->bar, 42, '... got the right bar'); is($o->baz, 47, '... got the right bar'); } { my $o = $class->new(42, baz => 47); is($o->bar, 42, '... got the right bar'); is($o->baz, 47, '... got the right bar'); } } done_testing; Interface.pm100600000767000024 10112200352344 16444 0ustar00etherstaff000000000000Moose-2.1005/t/lib/Rolepackage Role::Interface; use Moose::Role; requires "meth2"; 1; new_meta_role.t100644000767000024 46212200352344 16712 0ustar00etherstaff000000000000Moose-2.1005/t/roles#!/usr/bin/env perl use strict; use warnings; use Test::More; do { package My::Meta::Role; use Moose; BEGIN { extends 'Moose::Meta::Role' }; }; do { package My::Role; use Moose::Role -metaclass => 'My::Meta::Role'; }; is(My::Role->meta->meta->name, 'My::Meta::Role'); done_testing; use_base_does.t100644000767000024 117312200352344 16712 0ustar00etherstaff000000000000Moose-2.1005/t/roles#!/usr/bin/env perl use strict; use warnings; use Test::More; { package Foo::Role; use Moose::Role; } { package Foo; use Moose; with 'Foo::Role'; } { package Foo::Sub; use base 'Foo'; } { package Foo::Sub2; use base 'Foo'; } { package Foo::Sub3; use base 'Foo'; } { package Foo::Sub4; use base 'Foo'; } ok(Foo::Sub->does('Foo::Role'), "class does Foo::Role"); ok(Foo::Sub2->new->does('Foo::Role'), "object does Foo::Role"); ok(!Foo::Sub3->does('Bar::Role'), "class doesn't do Bar::Role"); ok(!Foo::Sub4->new->does('Bar::Role'), "object doesn't do Bar::Role"); done_testing; pod-syntax.t100644000767000024 21212200352344 16655 0ustar00etherstaff000000000000Moose-2.1005/xt/release#!perl use Test::More; eval "use Test::Pod 1.41"; plan skip_all => "Test::Pod 1.41 required for testing POD" if $@; all_pod_files_ok(); RequireAuthorDeps.pm100644000767000024 114712200352344 17061 0ustar00etherstaff000000000000Moose-2.1005/incpackage inc::RequireAuthorDeps; use Class::Load qw(load_class); use Moose; use CPAN::Meta::Requirements; use Try::Tiny; with 'Dist::Zilla::Role::BeforeRelease'; sub before_release { my $self = shift; $self->log("Ensuring all author dependencies are installed"); my $req = CPAN::Meta::Requirements->new; my $prereqs = $self->zilla->prereqs; for my $phase (qw(build test configure runtime develop)) { $req->add_requirements($prereqs->requirements_for($phase, 'requires')); } for my $mod (grep { $_ ne 'perl' } $req->required_modules) { load_class($mod); } } 1; Package.pm100644000767000024 2624012200352344 16517 0ustar00etherstaff000000000000Moose-2.1005/lib/Class/MOP package Class::MOP::Package; BEGIN { $Class::MOP::Package::AUTHORITY = 'cpan:STEVAN'; } { $Class::MOP::Package::VERSION = '2.1005'; } use strict; use warnings; use Scalar::Util 'blessed', 'reftype', 'weaken'; use Carp 'confess'; use Devel::GlobalDestruction 'in_global_destruction'; use Package::Stash; use base 'Class::MOP::Object'; # creation ... sub initialize { my ( $class, @args ) = @_; unshift @args, "package" if @args % 2; my %options = @args; my $package_name = delete $options{package}; # we hand-construct the class until we can bootstrap it if ( my $meta = Class::MOP::get_metaclass_by_name($package_name) ) { return $meta; } else { my $meta = ( ref $class || $class )->_new({ 'package' => $package_name, %options, }); Class::MOP::store_metaclass_by_name($package_name, $meta); Class::MOP::weaken_metaclass($package_name) if $options{weaken}; return $meta; } } sub reinitialize { my ( $class, @args ) = @_; unshift @args, "package" if @args % 2; my %options = @args; my $package_name = delete $options{package}; (defined $package_name && $package_name && (!blessed $package_name || $package_name->isa('Class::MOP::Package'))) || confess "You must pass a package name or an existing Class::MOP::Package instance"; $package_name = $package_name->name if blessed $package_name; Class::MOP::remove_metaclass_by_name($package_name); $class->initialize($package_name, %options); # call with first arg form for compat } sub create { my $class = shift; my @args = @_; return $class->initialize(@args); } ## ANON packages { # NOTE: # this should be sufficient, if you have a # use case where it is not, write a test and # I will change it. my $ANON_SERIAL = 0; my %ANON_PACKAGE_CACHE; # NOTE: # we need a sufficiently annoying prefix # this should suffice for now, this is # used in a couple of places below, so # need to put it up here for now. sub _anon_package_prefix { 'Class::MOP::Package::__ANON__::SERIAL::' } sub is_anon { my $self = shift; no warnings 'uninitialized'; my $prefix = $self->_anon_package_prefix; $self->name =~ /^\Q$prefix/; } sub create_anon { my ($class, %options) = @_; my $cache_ok = delete $options{cache}; $options{weaken} = !$cache_ok unless exists $options{weaken}; my $cache_key; if ($cache_ok) { $cache_key = $class->_anon_cache_key(%options); undef $cache_ok if !defined($cache_key); } if ($cache_ok) { if (defined $ANON_PACKAGE_CACHE{$cache_key}) { return $ANON_PACKAGE_CACHE{$cache_key}; } } my $package_name = $class->_anon_package_prefix . ++$ANON_SERIAL; my $meta = $class->create($package_name, %options); if ($cache_ok) { $ANON_PACKAGE_CACHE{$cache_key} = $meta; weaken($ANON_PACKAGE_CACHE{$cache_key}); } return $meta; } sub _anon_cache_key { confess "Packages are not cacheable" } sub DESTROY { my $self = shift; return if in_global_destruction(); # it'll happen soon anyway and this just makes things more complicated $self->_free_anon if $self->is_anon; } sub _free_anon { my $self = shift; my $name = $self->name; # Moose does a weird thing where it replaces the metaclass for # class when fixing metaclass incompatibility. In that case, # we don't want to clean out the namespace now. We can detect # that because Moose will explicitly update the singleton # cache in Class::MOP using store_metaclass_by_name, which # means that the new metaclass will already exist in the cache # by this point. # The other options here are that $current_meta can be undef if # remove_metaclass_by_name is called explicitly (since the hash # entry is removed first, and then this destructor is called), # or that $current_meta can be the same as $self, which happens # when the metaclass goes out of scope (since the weak reference # in the metaclass cache won't be freed until after this # destructor runs). my $current_meta = Class::MOP::get_metaclass_by_name($name); return if defined($current_meta) && $current_meta ne $self; my ($first_fragments, $last_fragment) = ($name =~ /^(.*)::(.*)$/); no strict 'refs'; # clear @ISA first, to avoid a memory leak # see https://rt.perl.org/rt3/Public/Bug/Display.html?id=92708 @{$name . '::ISA'} = (); %{$name . '::'} = (); delete ${$first_fragments . '::'}{$last_fragment . '::'}; Class::MOP::remove_metaclass_by_name($name); } } sub _new { my $class = shift; return Class::MOP::Class->initialize($class)->new_object(@_) if $class ne __PACKAGE__; my $params = @_ == 1 ? $_[0] : {@_}; return bless { # Need to quote package to avoid a problem with PPI mis-parsing this # as a package statement. 'package' => $params->{package}, # NOTE: # because of issues with the Perl API # to the typeglob in some versions, we # need to just always grab a new # reference to the hash in the accessor. # Ideally we could just store a ref and # it would Just Work, but oh well :\ namespace => \undef, } => $class; } # Attributes # NOTE: # all these attribute readers will be bootstrapped # away in the Class::MOP bootstrap section sub _package_stash { $_[0]->{_package_stash} ||= Package::Stash->new($_[0]->name) } sub namespace { $_[0]->_package_stash->namespace } # Class attributes # ... these functions have to touch the symbol table itself,.. yuk sub add_package_symbol { my $self = shift; $self->_package_stash->add_symbol(@_); } sub remove_package_glob { my $self = shift; $self->_package_stash->remove_glob(@_); } # ... these functions deal with stuff on the namespace level sub has_package_symbol { my $self = shift; $self->_package_stash->has_symbol(@_); } sub get_package_symbol { my $self = shift; $self->_package_stash->get_symbol(@_); } sub get_or_add_package_symbol { my $self = shift; $self->_package_stash->get_or_add_symbol(@_); } sub remove_package_symbol { my $self = shift; $self->_package_stash->remove_symbol(@_); } sub list_all_package_symbols { my $self = shift; $self->_package_stash->list_all_symbols(@_); } sub get_all_package_symbols { my $self = shift; $self->_package_stash->get_all_symbols(@_); } 1; # ABSTRACT: Package Meta Object __END__ =pod =head1 NAME Class::MOP::Package - Package Meta Object =head1 VERSION version 2.1005 =head1 DESCRIPTION The Package Protocol provides an abstraction of a Perl 5 package. A package is basically namespace, and this module provides methods for looking at and changing that namespace's symbol table. =head1 METHODS =over 4 =item B<< Class::MOP::Package->initialize($package_name, %options) >> This method creates a new C instance which represents specified package. If an existing metaclass object exists for the package, that will be returned instead. No options are valid at the package level. =item B<< Class::MOP::Package->reinitialize($package, %options) >> This method forcibly removes any existing metaclass for the package before calling C. In contrast to C, you may also pass an existing C instance instead of just a package name as C<$package>. Do not call this unless you know what you are doing. =item B<< Class::MOP::Package->create($package, %options) >> Creates a new C instance which represents the specified package, and also does some initialization of that package. Currently, this just does the same thing as C, but is overridden in subclasses, such as C. =item B<< Class::MOP::Package->create_anon(%options) >> Creates a new anonymous package. Valid keys for C<%options> are: =over 4 =item C If this is true (the default), the instance stored in C's metaclass cache will be weakened, so that the anonymous package will be garbage collected when the returned instance goes out of scope. =back =item B<< $metapackage->is_anon >> Returns true if the package is an anonymous package. =item B<< $metapackage->name >> This is returns the package's name, as passed to the constructor. =item B<< $metapackage->namespace >> This returns a hash reference to the package's symbol table. The keys are symbol names and the values are typeglob references. =item B<< $metapackage->add_package_symbol($variable_name, $initial_value) >> This method accepts a variable name and an optional initial value. The C<$variable_name> must contain a leading sigil. This method creates the variable in the package's symbol table, and sets it to the initial value if one was provided. =item B<< $metapackage->get_package_symbol($variable_name) >> Given a variable name, this method returns the variable as a reference or undef if it does not exist. The C<$variable_name> must contain a leading sigil. =item B<< $metapackage->get_or_add_package_symbol($variable_name) >> Given a variable name, this method returns the variable as a reference. If it does not exist, a default value will be generated if possible. The C<$variable_name> must contain a leading sigil. =item B<< $metapackage->has_package_symbol($variable_name) >> Returns true if there is a package variable defined for C<$variable_name>. The C<$variable_name> must contain a leading sigil. =item B<< $metapackage->remove_package_symbol($variable_name) >> This will remove the package variable specified C<$variable_name>. The C<$variable_name> must contain a leading sigil. =item B<< $metapackage->remove_package_glob($glob_name) >> Given the name of a glob, this will remove that glob from the package's symbol table. Glob names do not include a sigil. Removing the glob removes all variables and subroutines with the specified name. =item B<< $metapackage->list_all_package_symbols($type_filter) >> This will list all the glob names associated with the current package. These names do not have leading sigils. You can provide an optional type filter, which should be one of 'SCALAR', 'ARRAY', 'HASH', or 'CODE'. =item B<< $metapackage->get_all_package_symbols($type_filter) >> This works much like C, but it returns a hash reference. The keys are glob names and the values are references to the value for that name. =item B<< Class::MOP::Package->meta >> This will return a L instance for this class. =back =head1 AUTHOR Moose is maintained by the Moose Cabal, along with the help of many contributors. See L and L for details. =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2013 by Infinity Interactive, Inc.. This is free software; you can redistribute it and/or modify it under the same terms as the Perl 5 programming language system itself. =cut Croak.pm100644000767000024 271112200352344 16653 0ustar00etherstaff000000000000Moose-2.1005/lib/Moose/Errorpackage Moose::Error::Croak; BEGIN { $Moose::Error::Croak::AUTHORITY = 'cpan:STEVAN'; } { $Moose::Error::Croak::VERSION = '2.1005'; } use strict; use warnings; use base qw(Moose::Error::Default); sub new { my ( $self, @args ) = @_; $self->create_error_croak(@args); } sub _inline_new { my ( $self, %args ) = @_; my $depth = ($args{depth} || 0) - 1; return 'Moose::Error::Util::create_error_croak(' . 'message => ' . $args{message} . ', ' . 'depth => ' . $depth . ', ' . ')'; } 1; # ABSTRACT: Prefer C __END__ =pod =head1 NAME Moose::Error::Croak - Prefer C =head1 VERSION version 2.1005 =head1 SYNOPSIS # Metaclass definition must come before Moose is used. use metaclass ( metaclass => 'Moose::Meta::Class', error_class => 'Moose::Error::Croak', ); use Moose; # ... =head1 DESCRIPTION This error class uses L to raise errors generated in your metaclass. =head1 METHODS =over 4 =item new Overrides L to prefer C. =back =head1 AUTHOR Moose is maintained by the Moose Cabal, along with the help of many contributors. See L and L for details. =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2013 by Infinity Interactive, Inc.. This is free software; you can redistribute it and/or modify it under the same terms as the Perl 5 programming language system itself. =cut Manual000755000767000024 012200352344 15241 5ustar00etherstaff000000000000Moose-2.1005/lib/MooseFAQ.pod100644000767000024 3457312200352344 16550 0ustar00etherstaff000000000000Moose-2.1005/lib/Moose/Manualpackage Moose::Manual::FAQ; # ABSTRACT: Frequently asked questions about Moose __END__ =pod =head1 NAME Moose::Manual::FAQ - Frequently asked questions about Moose =head1 VERSION version 2.1005 =head1 FREQUENTLY ASKED QUESTIONS =head2 Module Stability =head3 Is Moose "production ready"? Yes! Many sites with household names are using Moose to build high-traffic services. Countless others are using Moose in production. See L for a partial list. As of this writing, Moose is a dependency of several hundred CPAN modules. L =head3 Is Moose's API stable? Yes. The sugary API, the one 95% of users will interact with, is B. Any changes will be B<100% backwards compatible>. The meta API is less set in stone. We reserve the right to tweak parts of it to improve efficiency or consistency. This will not be done lightly. We do perform deprecation cycles. We I do not like making ourselves look bad by breaking your code. Submitting test cases is the best way to ensure that your code is not inadvertently broken by refactoring. =head3 I heard Moose is slow, is this true? Again, this one is tricky, so Yes I No. Firstly, I in life is free, and some Moose features do cost more than others. It is also the policy of Moose to B, and to do our absolute best to not place any extra burdens on the execution of your code for features you are not using. Of course using Moose itself does involve some overhead, but it is mostly compile time. At this point we do have some options available for getting the speed you need. Currently we provide the option of making your classes immutable as a means of boosting speed. This will mean a slightly larger compile time cost, but the runtime speed increase (especially in object construction) is pretty significant. This can be done with the following code: MyClass->meta->make_immutable(); =head2 Constructors =head3 How do I write custom constructors with Moose? Ideally, you should never write your own C method, and should use Moose's other features to handle your specific object construction needs. Here are a few scenarios, and the Moose way to solve them; If you need to call initialization code post instance construction, then use the C method. This feature is taken directly from Perl 6. Every C method in your inheritance chain is called (in the correct order) immediately after the instance is constructed. This allows you to ensure that all your superclasses are initialized properly as well. This is the best approach to take (when possible) because it makes subclassing your class much easier. If you need to affect the constructor's parameters prior to the instance actually being constructed, you have a number of options. To change the parameter processing as a whole, you can use the C method. The default implementation accepts key/value pairs or a hash reference. You can override it to take positional args, or any other format To change the handling of individual parameters, there are I (See the L for a complete example and explanation of coercions). With coercions it is possible to morph argument values into the correct expected types. This approach is the most flexible and robust, but does have a slightly higher learning curve. =head3 How do I make non-Moose constructors work with Moose? Usually the correct approach to subclassing a non-Moose class is delegation. Moose makes this easy using the C keyword, coercions, and C, so subclassing is often not the ideal route. That said, if you really need to inherit from a non-Moose class, see L for an example of how to do it, or take a look at L. =head2 Accessors =head3 How do I tell Moose to use get/set accessors? The easiest way to accomplish this is to use the C and C attribute options: has 'bar' => ( isa => 'Baz', reader => 'get_bar', writer => 'set_bar', ); Moose will still take advantage of type constraints, triggers, etc. when creating these methods. If you do not like this much typing, and wish it to be a default for your classes, please see L. This extension will allow you to write: has 'bar' => ( isa => 'Baz', is => 'rw', ); Moose will create separate C and C methods instead of a single C method. If you like C and C, see L. NOTE: This B be set globally in Moose, as that would break other classes which are built with Moose. You can still save on typing by defining a new C that exports Moose's sugar and then turns on L. See L. =head3 How can I inflate/deflate values in accessors? Well, the first question to ask is if you actually need both inflate and deflate. If you only need to inflate, then we suggest using coercions. Here is some basic sample code for inflating a L object: class_type 'DateTime'; coerce 'DateTime' => from 'Str' => via { DateTime::Format::MySQL->parse_datetime($_) }; has 'timestamp' => (is => 'rw', isa => 'DateTime', coerce => 1); This creates a custom type for L objects, then attaches a coercion to that type. The C attribute is then told to expect a C type, and to try to coerce it. When a C type is given to the C accessor, it will attempt to coerce the value into a C object using the code in found in the C block. For a more comprehensive example of using coercions, see the L. If you need to deflate your attribute's value, the current best practice is to add an C modifier to your accessor: # a timestamp which stores as # seconds from the epoch has 'timestamp' => (is => 'rw', isa => 'Int'); around 'timestamp' => sub { my $next = shift; my $self = shift; return $self->$next unless @_; # assume we get a DateTime object ... my $timestamp = shift; return $self->$next( $timestamp->epoch ); }; It is also possible to do deflation using coercion, but this tends to get quite complex and require many subtypes. An example of this is outside the scope of this document, ask on #moose or send a mail to the list. Still another option is to write a custom attribute metaclass, which is also outside the scope of this document, but we would be happy to explain it on #moose or the mailing list. =head2 Method Modifiers =head3 How can I affect the values in C<@_> using C? You can't, actually: C only runs before the main method, and it cannot easily affect the method's execution. You similarly can't use C to affect the return value of a method. We limit C and C because this lets you write more concise code. You do not have to worry about passing C<@_> to the original method, or forwarding its return value (being careful to preserve context). The C method modifier has neither of these limitations, but is a little more verbose. Alternatively, the L extension provides the C function, which does allow you to affect C<@_>. =head3 Can I use C to stop execution of a method? Yes, but only if you throw an exception. If this is too drastic a measure then we suggest using C instead. The C method modifier is the only modifier which can gracefully prevent execution of the main method. Here is an example: around 'baz' => sub { my $next = shift; my ($self, %options) = @_; unless ($options->{bar} eq 'foo') { return 'bar'; } $self->$next(%options); }; By choosing not to call the C<$next> method, you can stop the execution of the main method. Alternatively, the L extension provides the C function, which will conditionally prevent execution of the original method. =head3 Why can't I see return values in an C modifier? As with the C modifier, the C modifier is simply called I the main method. It is passed the original contents of C<@_> and B the return values of the main method. Again, the arguments are too lengthy as to why this has to be. And as with C I recommend using an C modifier instead. Here is some sample code: around 'foo' => sub { my $next = shift; my ($self, @args) = @_; my @rv = $next->($self, @args); # do something silly with the return values return reverse @rv; }; Alternatively, the L extension provides the C function, which allows modifying the return values of the original method. =head2 Type Constraints =head3 How can I provide a custom error message for a type constraint? Use the C option when building the subtype: subtype 'NaturalLessThanTen' => as 'Natural' => where { $_ < 10 } => message { "This number ($_) is not less than ten!" }; This C block will be called when a value fails to pass the C constraint check. =head3 Can I turn off type constraint checking? There's no support for it in the core of Moose yet. This option may come in a future release. Meanwhile there's a L that allows you to do this on a per-attribute basis, and if it doesn't do what you it's easy to write one that fits your use case. =head3 My coercions stopped working with recent Moose, why did you break it? Moose 0.76 fixed a case where coercions were being applied even if the original constraint passed. This has caused some edge cases to fail where people were doing something like subtype 'Address', as 'Str'; coerce 'Address', from 'Str', via { get_address($_) }; This is not what they intended, because the type constraint C
is too loose in this case. It is saying that all strings are Addresses, which is obviously not the case. The solution is to provide a C clause that properly restricts the type constraint: subtype 'Address', as 'Str', where { looks_like_address($_) }; This will allow the coercion to apply only to strings that fail to look like an Address. =head2 Roles =head3 Why is BUILD not called for my composed roles? C is never called in composed roles. The primary reason is that roles are B order sensitive. Roles are composed in such a way that the order of composition does not matter (for information on the deeper theory of this read the original traits papers here L). Because roles are essentially unordered, it would be impossible to determine the order in which to execute the C methods. As for alternate solutions, there are a couple. =over 4 =item * Using a combination of lazy and default in your attributes to defer initialization (see the Binary Tree example in the cookbook for a good example of lazy/default usage L) =item * Use attribute triggers, which fire after an attribute is set, to facilitate initialization. These are described in the L docs, and examples can be found in the test suite. =back In general, roles should not I initialization; they should either provide sane defaults or should be documented as needing specific initialization. One such way to "document" this is to have a separate attribute initializer which is required for the role. Here is an example of how to do this: package My::Role; use Moose::Role; has 'height' => ( is => 'rw', isa => 'Int', lazy => 1, default => sub { my $self = shift; $self->init_height; } ); requires 'init_height'; In this example, the role will not compose successfully unless the class provides a C method. If none of those solutions work, then it is possible that a role is not the best tool for the job, and you really should be using classes. Or, at the very least, you should reduce the amount of functionality in your role so that it does not require initialization. =head3 What are traits, and how are they different from roles? In Moose, a trait is almost exactly the same thing as a role, except that traits typically register themselves, which allows you to refer to them by a short name ("Big" vs "MyApp::Role::Big"). In Moose-speak, a I is usually composed into a I at compile time, whereas a I is usually composed into an instance of a class at runtime to add or modify the behavior of B. Outside the context of Moose, traits and roles generally mean exactly the same thing. The original paper called them traits, but Perl 6 will call them roles. =head3 Can an attribute-generated method (e.g. an accessor) satisfy requires? Yes, just be sure to consume the role I declaring your attribute. L provides an example: package Breakable; use Moose::Role; requires 'stress'; package Car; use Moose; has 'stress' => ( is => 'rw', isa => 'Int' ); with 'Breakable'; If you mistakenly consume the C role before declaring your C attribute, you would see an error like this: 'Breakable' requires the method 'stress' to be implemented by 'Car' at... =head2 Moose and Subroutine Attributes =head3 Why don't subroutine attributes I inherited from a superclass work? Currently when subclassing a module is done at runtime with the C keyword, but attributes are checked at compile time by Perl. To make attributes work, you must place C in a C block so that the attribute handlers will be available at compile time, like this: BEGIN { extends qw/Foo/ } Note that we're talking about Perl's subroutine attributes here, not Moose attributes: sub foo : Bar(27) { ... } =head1 AUTHOR Moose is maintained by the Moose Cabal, along with the help of many contributors. See L and L for details. =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2013 by Infinity Interactive, Inc.. This is free software; you can redistribute it and/or modify it under the same terms as the Perl 5 programming language system itself. =cut MOP.pod100644000767000024 1336712200352344 16572 0ustar00etherstaff000000000000Moose-2.1005/lib/Moose/Manualpackage Moose::Manual::MOP; # ABSTRACT: The Moose (and Class::MOP) meta API __END__ =pod =head1 NAME Moose::Manual::MOP - The Moose (and Class::MOP) meta API =head1 VERSION version 2.1005 =head1 INTRODUCTION Moose provides a powerful introspection API built on top of C. "MOP" stands for Meta-Object Protocol. In plainer English, a MOP is an API for performing introspection on classes, attributes, methods, and so on. In fact, it is C that provides many of Moose's core features, including attributes, before/after/around method modifiers, and immutability. In most cases, Moose takes an existing C class and subclasses it to add additional features. Moose also adds some entirely new features of its own, such as roles, the augment modifier, and types. If you're interested in the MOP, it's important to know about C so you know what docs to read. Often, the introspection method that you're looking for is defined in a C class, rather than Moose itself. The MOP provides more than just I introspection. It also lets you add attributes and methods, apply roles, and much more. In fact, all of the declarative Moose sugar is simply a thin layer on top of the MOP API. If you want to write Moose extensions, you'll need to learn some of the MOP API. The introspection methods are also handy if you want to generate docs or inheritance graphs, or do some other runtime reflection. This document is not a complete reference for the meta API. We're just going to cover some of the highlights, and give you a sense of how it all works. To really understand it, you'll have to read a lot of other docs, and possibly even dig into the Moose guts a bit. =head1 GETTING STARTED The usual entry point to the meta API is through a class's metaclass object, which is a L. This is available by calling the C method on a class or object: package User; use Moose; my $meta = __PACKAGE__->meta; The C method is added to a class when it uses Moose. You can also use C<< Class::MOP::Class->initialize($name) >> to get a metaclass object for any class. This is safer than calling C<< $class->meta >> when you're not sure that the class has a meta method. The C<< Class::MOP::Class->initialize >> constructor will return an existing metaclass if one has already been created (via Moose or some other means). If it hasn't, it will return a new C object. This will work for classes that use Moose, meta API classes, and classes which don't use Moose at all. =head1 USING THE METACLASS OBJECT The metaclass object can tell you about a class's attributes, methods, roles, parents, and more. For example, to look at all of the class's attributes: for my $attr ( $meta->get_all_attributes ) { print $attr->name, "\n"; } The C method is documented in C. For Moose-using classes, it returns a list of L objects for attributes defined in the class and its parents. You can also get a list of methods: for my $method ( $meta->get_all_methods ) { print $method->fully_qualified_name, "\n"; } Now we're looping over a list of L objects. Note that some of these objects may actually be a subclass of L, as Moose uses different classes to represent wrapped methods, delegation methods, constructors, etc. We can look at a class's parent classes and subclasses: for my $class ( $meta->linearized_isa ) { print "$class\n"; } for my $subclass ( $meta->subclasses ) { print "$subclass\n"; } Note that both these methods return class I, not metaclass objects. =head1 ALTERING CLASSES WITH THE MOP The metaclass object can change the class directly, by adding attributes, methods, etc. As an example, we can add a method to a class: $meta->add_method( 'say' => sub { print @_, "\n" } ); Or an attribute: $meta->add_attribute( 'size' => ( is => 'rw', isa => 'Int' ) ); Obviously, this is much more cumbersome than using Perl syntax or Moose sugar for defining methods and attributes, but this API allows for very powerful extensions. You might remember that we've talked about making classes immutable elsewhere in the manual. This is a good practice. However, once a class is immutable, calling any of these update methods will throw an exception. You can make a class mutable again simply by calling C<< $meta->make_mutable >>. Once you're done changing it, you can restore immutability by calling C<< $meta->make_immutable >>. However, the most common use for this part of the meta API is as part of Moose extensions. These extensions should assume that they are being run before you make a class immutable. =head1 GOING FURTHER If you're interested in extending Moose, we recommend reading all of the "Meta" and "Extending" recipes in the L. Those recipes show various practical applications of the MOP. If you'd like to write your own extensions, one of the best ways to learn more about this is to look at other similar extensions to see how they work. You'll probably also need to read various API docs, including the docs for the various C and C classes. Finally, we welcome questions on the Moose mailing list and IRC. Information on the mailing list, IRC, and more references can be found in the L. =head1 AUTHOR Moose is maintained by the Moose Cabal, along with the help of many contributors. See L and L for details. =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2013 by Infinity Interactive, Inc.. This is free software; you can redistribute it and/or modify it under the same terms as the Perl 5 programming language system itself. =cut Method.pm100644000767000024 436012200352344 16633 0ustar00etherstaff000000000000Moose-2.1005/lib/Moose/Metapackage Moose::Meta::Method; BEGIN { $Moose::Meta::Method::AUTHORITY = 'cpan:STEVAN'; } { $Moose::Meta::Method::VERSION = '2.1005'; } use strict; use warnings; use Class::MOP::MiniTrait; use base 'Class::MOP::Method'; Class::MOP::MiniTrait::apply(__PACKAGE__, 'Moose::Meta::Object::Trait'); sub _error_thrower { my $self = shift; require Moose::Meta::Class; ( ref $self && $self->associated_metaclass ) || "Moose::Meta::Class"; } sub throw_error { my $self = shift; my $inv = $self->_error_thrower; unshift @_, "message" if @_ % 2 == 1; unshift @_, method => $self if ref $self; unshift @_, $inv; my $handler = $inv->can("throw_error"); goto $handler; # to avoid incrementing depth by 1 } sub _inline_throw_error { my ( $self, $msg, $args ) = @_; my $inv = $self->_error_thrower; # XXX ugh $inv = 'Moose::Meta::Class' unless $inv->can('_inline_throw_error'); # XXX ugh ugh UGH my $class = $self->associated_metaclass; if ($class) { my $class_name = B::perlstring($class->name); my $meth_name = B::perlstring($self->name); $args = 'method => Class::MOP::class_of(' . $class_name . ')' . '->find_method_by_name(' . $meth_name . '), ' . (defined $args ? $args : ''); } return $inv->_inline_throw_error($msg, $args) } 1; # ABSTRACT: A Moose Method metaclass __END__ =pod =head1 NAME Moose::Meta::Method - A Moose Method metaclass =head1 VERSION version 2.1005 =head1 DESCRIPTION This class is a subclass of L that provides additional Moose-specific functionality, all of which is private. To understand this class, you should read the the L documentation. =head1 INHERITANCE C is a subclass of L. =head1 BUGS See L for details on reporting bugs. =head1 AUTHOR Moose is maintained by the Moose Cabal, along with the help of many contributors. See L and L for details. =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2013 by Infinity Interactive, Inc.. This is free software; you can redistribute it and/or modify it under the same terms as the Perl 5 programming language system itself. =cut super_recursion.t100644000767000024 244012200352344 17153 0ustar00etherstaff000000000000Moose-2.1005/t/bugsuse strict; use warnings; use Test::More; { package A; use Moose; sub foo { ::BAIL_OUT('A::foo called twice') if $main::seen{'A::foo'}++; return 'a'; } sub bar { ::BAIL_OUT('A::bar called twice') if $main::seen{'A::bar'}++; return 'a'; } sub baz { ::BAIL_OUT('A::baz called twice') if $main::seen{'A::baz'}++; return 'a'; } } { package B; use Moose; extends qw(A); sub foo { ::BAIL_OUT('B::foo called twice') if $main::seen{'B::foo'}++; return 'b' . super(); } sub bar { ::BAIL_OUT('B::bar called twice') if $main::seen{'B::bar'}++; return 'b' . ( super() || '' ); } override baz => sub { ::BAIL_OUT('B::baz called twice') if $main::seen{'B::baz'}++; return 'b' . super(); }; } { package C; use Moose; extends qw(B); sub foo { return 'c' . ( super() || '' ) } override bar => sub { ::BAIL_OUT('C::bar called twice') if $main::seen{'C::bar'}++; return 'c' . super(); }; override baz => sub { ::BAIL_OUT('C::baz called twice') if $main::seen{'C::baz'}++; return 'c' . super(); }; } is( C->new->foo, 'c' ); is( C->new->bar, 'cb' ); is( C->new->baz, 'cba' ); done_testing; anon_class_leak.t100644000767000024 100712200352344 17034 0ustar00etherstaff000000000000Moose-2.1005/t/cmopuse strict; use warnings; use Class::MOP; use Test::More; use Test::Requires { 'Test::LeakTrace' => '0.01', # skip all if not installed }; # 5.10.0 has a bug on weaken($hash_ref) which leaks an AV. my $expected = ( $] == 5.010_000 ? 1 : 0 ); leaks_cmp_ok { Class::MOP::Class->create_anon_class(); } '<=', $expected, 'create_anon_class()'; leaks_cmp_ok { Class::MOP::Class->create_anon_class( superclasses => [qw(Exporter)] ); } '<=', $expected, 'create_anon_class(superclass => [...])'; done_testing; BinaryTree_test.t100644000767000024 2547012200352344 17055 0ustar00etherstaff000000000000Moose-2.1005/t/cmopuse strict; use warnings; use FindBin; use File::Spec::Functions; use Test::More; use Test::Fatal; use Class::Load qw( is_class_loaded load_class ); use lib catdir($FindBin::Bin, 'lib'); ## ---------------------------------------------------------------------------- ## These are all tests which are derived from the Tree::Binary test suite ## ---------------------------------------------------------------------------- ok(!is_class_loaded('BinaryTree'), '... the binary tree class is not loaded'); is( exception { load_class('BinaryTree'); }, undef, '... loaded the BinaryTree class without dying' ); ok(is_class_loaded('BinaryTree'), '... the binary tree class is now loaded'); ## ---------------------------------------------------------------------------- ## t/10_Tree_Binary_test.t can_ok("BinaryTree", 'new'); can_ok("BinaryTree", 'setLeft'); can_ok("BinaryTree", 'setRight'); my $btree = BinaryTree->new("/") ->setLeft( BinaryTree->new("+") ->setLeft( BinaryTree->new("2") ) ->setRight( BinaryTree->new("2") ) ) ->setRight( BinaryTree->new("*") ->setLeft( BinaryTree->new("4") ) ->setRight( BinaryTree->new("5") ) ); isa_ok($btree, 'BinaryTree'); ## informational methods can_ok($btree, 'isRoot'); ok($btree->isRoot(), '... this is the root'); can_ok($btree, 'isLeaf'); ok(!$btree->isLeaf(), '... this is not a leaf node'); ok($btree->getLeft()->getLeft()->isLeaf(), '... this is a leaf node'); can_ok($btree, 'hasLeft'); ok($btree->hasLeft(), '... this has a left node'); can_ok($btree, 'hasRight'); ok($btree->hasRight(), '... this has a right node'); ## accessors can_ok($btree, 'getUID'); { my $UID = $btree->getUID(); is(("$btree" =~ /\((.*?)\)$/)[0], $UID, '... our UID is derived from the stringified object'); } can_ok($btree, 'getNodeValue'); is($btree->getNodeValue(), '/', '... got what we expected'); { can_ok($btree, 'getLeft'); my $left = $btree->getLeft(); isa_ok($left, 'BinaryTree'); is($left->getNodeValue(), '+', '... got what we expected'); can_ok($left, 'getParent'); my $parent = $left->getParent(); isa_ok($parent, 'BinaryTree'); is($parent, $btree, '.. got what we expected'); } { can_ok($btree, 'getRight'); my $right = $btree->getRight(); isa_ok($right, 'BinaryTree'); is($right->getNodeValue(), '*', '... got what we expected'); can_ok($right, 'getParent'); my $parent = $right->getParent(); isa_ok($parent, 'BinaryTree'); is($parent, $btree, '.. got what we expected'); } ## mutators can_ok($btree, 'setUID'); $btree->setUID("Our UID for this tree"); is($btree->getUID(), 'Our UID for this tree', '... our UID is not what we expected'); can_ok($btree, 'setNodeValue'); $btree->setNodeValue('*'); is($btree->getNodeValue(), '*', '... got what we expected'); { can_ok($btree, 'removeLeft'); my $left = $btree->removeLeft(); isa_ok($left, 'BinaryTree'); ok(!$btree->hasLeft(), '... we dont have a left node anymore'); ok(!$btree->isLeaf(), '... and we are not a leaf node'); $btree->setLeft($left); ok($btree->hasLeft(), '... we have our left node again'); is($btree->getLeft(), $left, '... and it is what we told it to be'); } { # remove left leaf my $left_leaf = $btree->getLeft()->removeLeft(); isa_ok($left_leaf, 'BinaryTree'); ok($left_leaf->isLeaf(), '... our left leaf is a leaf'); ok(!$btree->getLeft()->hasLeft(), '... we dont have a left leaf node anymore'); $btree->getLeft()->setLeft($left_leaf); ok($btree->getLeft()->hasLeft(), '... we have our left leaf node again'); is($btree->getLeft()->getLeft(), $left_leaf, '... and it is what we told it to be'); } { can_ok($btree, 'removeRight'); my $right = $btree->removeRight(); isa_ok($right, 'BinaryTree'); ok(!$btree->hasRight(), '... we dont have a right node anymore'); ok(!$btree->isLeaf(), '... and we are not a leaf node'); $btree->setRight($right); ok($btree->hasRight(), '... we have our right node again'); is($btree->getRight(), $right, '... and it is what we told it to be') } { # remove right leaf my $right_leaf = $btree->getRight()->removeRight(); isa_ok($right_leaf, 'BinaryTree'); ok($right_leaf->isLeaf(), '... our right leaf is a leaf'); ok(!$btree->getRight()->hasRight(), '... we dont have a right leaf node anymore'); $btree->getRight()->setRight($right_leaf); ok($btree->getRight()->hasRight(), '... we have our right leaf node again'); is($btree->getRight()->getRight(), $right_leaf, '... and it is what we told it to be'); } # some of the recursive informational methods { my $btree = BinaryTree->new("o") ->setLeft( BinaryTree->new("o") ->setLeft( BinaryTree->new("o") ) ->setRight( BinaryTree->new("o") ->setLeft( BinaryTree->new("o") ->setLeft( BinaryTree->new("o") ->setRight(BinaryTree->new("o")) ) ) ) ) ->setRight( BinaryTree->new("o") ->setLeft( BinaryTree->new("o") ->setRight( BinaryTree->new("o") ->setLeft( BinaryTree->new("o") ) ->setRight( BinaryTree->new("o") ) ) ) ->setRight( BinaryTree->new("o") ->setRight(BinaryTree->new("o")) ) ); isa_ok($btree, 'BinaryTree'); can_ok($btree, 'size'); cmp_ok($btree->size(), '==', 14, '... we have 14 nodes in the tree'); can_ok($btree, 'height'); cmp_ok($btree->height(), '==', 6, '... the tree is 6 nodes tall'); } ## ---------------------------------------------------------------------------- ## t/13_Tree_Binary_mirror_test.t sub inOrderTraverse { my $tree = shift; my @results; my $_inOrderTraverse = sub { my ($tree, $traversal_function) = @_; $traversal_function->($tree->getLeft(), $traversal_function) if $tree->hasLeft(); push @results => $tree->getNodeValue(); $traversal_function->($tree->getRight(), $traversal_function) if $tree->hasRight(); }; $_inOrderTraverse->($tree, $_inOrderTraverse); @results; } # test it on a simple well balanaced tree { my $btree = BinaryTree->new(4) ->setLeft( BinaryTree->new(2) ->setLeft( BinaryTree->new(1) ) ->setRight( BinaryTree->new(3) ) ) ->setRight( BinaryTree->new(6) ->setLeft( BinaryTree->new(5) ) ->setRight( BinaryTree->new(7) ) ); isa_ok($btree, 'BinaryTree'); is_deeply( [ inOrderTraverse($btree) ], [ 1 .. 7 ], '... check that our tree starts out correctly'); can_ok($btree, 'mirror'); $btree->mirror(); is_deeply( [ inOrderTraverse($btree) ], [ reverse(1 .. 7) ], '... check that our tree ends up correctly'); } # test is on a more chaotic tree { my $btree = BinaryTree->new(4) ->setLeft( BinaryTree->new(20) ->setLeft( BinaryTree->new(1) ->setRight( BinaryTree->new(10) ->setLeft( BinaryTree->new(5) ) ) ) ->setRight( BinaryTree->new(3) ) ) ->setRight( BinaryTree->new(6) ->setLeft( BinaryTree->new(5) ->setRight( BinaryTree->new(7) ->setLeft( BinaryTree->new(90) ) ->setRight( BinaryTree->new(91) ) ) ) ); isa_ok($btree, 'BinaryTree'); my @results = inOrderTraverse($btree); $btree->mirror(); is_deeply( [ inOrderTraverse($btree) ], [ reverse(@results) ], '... this should be the reverse of the original'); } done_testing; custom_instance.t100644000767000024 616712200352344 17132 0ustar00etherstaff000000000000Moose-2.1005/t/cmop#!/usr/bin/env perl use strict; use warnings; use Test::More; use Test::Fatal; use Class::MOP; my $instance; { package Foo; sub new { my $class = shift; $instance = bless {@_}, $class; return $instance; } sub foo { shift->{foo} } } { package Foo::Sub; use base 'Foo'; use metaclass; sub new { my $class = shift; $class->meta->new_object( __INSTANCE__ => $class->SUPER::new(@_), @_, ); } __PACKAGE__->meta->add_attribute( bar => ( reader => 'bar', initializer => sub { my $self = shift; my ($value, $writer, $attr) = @_; $writer->(uc $value); }, ), ); } undef $instance; is( exception { my $foo = Foo::Sub->new; isa_ok($foo, 'Foo'); isa_ok($foo, 'Foo::Sub'); is($foo, $instance, "used the passed-in instance"); }, undef ); undef $instance; is( exception { my $foo = Foo::Sub->new(foo => 'FOO'); isa_ok($foo, 'Foo'); isa_ok($foo, 'Foo::Sub'); is($foo, $instance, "used the passed-in instance"); is($foo->foo, 'FOO', "set non-CMOP constructor args"); }, undef ); undef $instance; is( exception { my $foo = Foo::Sub->new(bar => 'bar'); isa_ok($foo, 'Foo'); isa_ok($foo, 'Foo::Sub'); is($foo, $instance, "used the passed-in instance"); is($foo->bar, 'BAR', "set CMOP attributes"); }, undef ); undef $instance; is( exception { my $foo = Foo::Sub->new(foo => 'FOO', bar => 'bar'); isa_ok($foo, 'Foo'); isa_ok($foo, 'Foo::Sub'); is($foo, $instance, "used the passed-in instance"); is($foo->foo, 'FOO', "set non-CMOP constructor arg"); is($foo->bar, 'BAR', "set correct CMOP attribute"); }, undef ); { package BadFoo; sub new { my $class = shift; $instance = bless {@_}; return $instance; } sub foo { shift->{foo} } } { package BadFoo::Sub; use base 'BadFoo'; use metaclass; sub new { my $class = shift; $class->meta->new_object( __INSTANCE__ => $class->SUPER::new(@_), @_, ); } __PACKAGE__->meta->add_attribute( bar => ( reader => 'bar', initializer => sub { my $self = shift; my ($value, $writer, $attr) = @_; $writer->(uc $value); }, ), ); } like( exception { BadFoo::Sub->new }, qr/BadFoo=HASH.*is not a BadFoo::Sub/, "error with incorrect constructors" ); { my $meta = Class::MOP::Class->create('Really::Bad::Foo'); like( exception { $meta->new_object(__INSTANCE__ => (bless {}, 'Some::Other::Class')) }, qr/Some::Other::Class=HASH.*is not a Really::Bad::Foo/, "error with completely invalid class" ); } { my $meta = Class::MOP::Class->create('Really::Bad::Foo::2'); for my $invalid ('foo', 1, 0, '') { like( exception { $meta->new_object(__INSTANCE__ => $invalid) }, qr/The __INSTANCE__ parameter must be a blessed reference, not $invalid/, "error with unblessed thing" ); } } done_testing; inline_structor.t100644000767000024 1545312200352344 17175 0ustar00etherstaff000000000000Moose-2.1005/t/cmopuse strict; use warnings; use Test::More; use Test::Requires { 'Test::Output' => '0.01', # skip all if not installed }; use Class::MOP; { package HasConstructor; sub new { bless {}, $_[0] } my $meta = Class::MOP::Class->initialize(__PACKAGE__); $meta->superclasses('NotMoose'); ::stderr_like( sub { $meta->make_immutable }, qr/\QNot inlining a constructor for HasConstructor since it defines its own constructor.\E\s+\QIf you are certain you don't need to inline your constructor, specify inline_constructor => 0 in your call to HasConstructor->meta->make_immutable\E/, 'got a warning that Foo will not have an inlined constructor because it defines its own new method' ); ::is( $meta->find_method_by_name('new')->body, HasConstructor->can('new'), 'HasConstructor->new was untouched' ); } { package My::Constructor; use base 'Class::MOP::Method::Constructor'; sub _expected_method_class { 'Base::Class' } } { package No::Constructor; } { package My::Constructor2; use base 'Class::MOP::Method::Constructor'; sub _expected_method_class { 'No::Constructor' } } { package Base::Class; sub new { bless {}, $_[0] } sub DESTROY { } } { package NotMoose; sub new { my $class = shift; return bless { not_moose => 1 }, $class; } } { package Foo; my $meta = Class::MOP::Class->initialize(__PACKAGE__); $meta->superclasses('NotMoose'); ::stderr_like( sub { $meta->make_immutable( constructor_class => 'My::Constructor' ) }, qr/\QNot inlining 'new' for Foo since it is not inheriting the default Base::Class::new\E\s+\QIf you are certain you don't need to inline your constructor, specify inline_constructor => 0 in your call to Foo->meta->make_immutable/, 'got a warning that Foo will not have an inlined constructor' ); ::is( $meta->find_method_by_name('new')->body, NotMoose->can('new'), 'Foo->new is inherited from NotMoose' ); } { package Bar; my $meta = Class::MOP::Class->initialize(__PACKAGE__); $meta->superclasses('NotMoose'); ::stderr_is( sub { $meta->make_immutable( replace_constructor => 1 ) }, q{}, 'no warning when replace_constructor is true' ); ::is( $meta->find_method_by_name('new')->package_name, 'Bar', 'Bar->new is inlined, and not inherited from NotMoose' ); } { package Baz; Class::MOP::Class->initialize(__PACKAGE__)->make_immutable; } { package Quux; my $meta = Class::MOP::Class->initialize(__PACKAGE__); $meta->superclasses('Baz'); ::stderr_is( sub { $meta->make_immutable }, q{}, 'no warning when inheriting from a class that has already made itself immutable' ); } { package Whatever; my $meta = Class::MOP::Class->initialize(__PACKAGE__); ::stderr_like( sub { $meta->make_immutable( constructor_class => 'My::Constructor2' ) }, qr/\QNot inlining 'new' for Whatever since No::Constructor::new is not defined/, 'got a warning that Whatever will not have an inlined constructor because its expected inherited method does not exist' ); } { package My::Constructor3; use base 'Class::MOP::Method::Constructor'; } { package CustomCons; Class::MOP::Class->initialize(__PACKAGE__)->make_immutable( constructor_class => 'My::Constructor3' ); } { package Subclass; my $meta = Class::MOP::Class->initialize(__PACKAGE__); $meta->superclasses('CustomCons'); ::stderr_is( sub { $meta->make_immutable }, q{}, 'no warning when inheriting from a class that has already made itself immutable' ); } { package ModdedNew; my $meta = Class::MOP::Class->initialize(__PACKAGE__); sub new { bless {}, shift } $meta->add_before_method_modifier( 'new' => sub { } ); } { package ModdedSub; my $meta = Class::MOP::Class->initialize(__PACKAGE__); $meta->superclasses('ModdedNew'); ::stderr_like( sub { $meta->make_immutable }, qr/\QNot inlining 'new' for ModdedSub since it has method modifiers which would be lost if it were inlined/, 'got a warning that ModdedSub will not have an inlined constructor since it inherited a wrapped new' ); } { package My::Destructor; use base 'Class::MOP::Method::Inlined'; sub new { my $class = shift; my %options = @_; my $self = bless \%options, $class; $self->_inline_destructor; return $self; } sub _inline_destructor { my $self = shift; my $code = $self->_compile_code('sub { }'); $self->{body} = $code; } sub is_needed { 1 } sub associated_metaclass { $_[0]->{metaclass} } sub body { $_[0]->{body} } sub _expected_method_class { 'Base::Class' } } { package HasDestructor; my $meta = Class::MOP::Class->initialize(__PACKAGE__); sub DESTROY { } ::stderr_like( sub { $meta->make_immutable( inline_destructor => 1, destructor_class => 'My::Destructor', ); }, qr/Not inlining a destructor for HasDestructor since it defines its own destructor./, 'got a warning when trying to inline a destructor for a class that already defines DESTROY' ); ::is( $meta->find_method_by_name('DESTROY')->body, HasDestructor->can('DESTROY'), 'HasDestructor->DESTROY was untouched' ); } { package HasDestructor2; my $meta = Class::MOP::Class->initialize(__PACKAGE__); sub DESTROY { } $meta->make_immutable( inline_destructor => 1, destructor_class => 'My::Destructor', replace_destructor => 1 ); ::stderr_is( sub { $meta->make_immutable( inline_destructor => 1, destructor_class => 'My::Destructor', replace_destructor => 1 ); }, q{}, 'no warning when replace_destructor is true' ); ::isnt( $meta->find_method_by_name('new')->body, HasConstructor2->can('new'), 'HasConstructor2->new was replaced' ); } { package ParentHasDestructor; sub DESTROY { } } { package DestructorChild; use base 'ParentHasDestructor'; my $meta = Class::MOP::Class->initialize(__PACKAGE__); ::stderr_like( sub { $meta->make_immutable( inline_destructor => 1, destructor_class => 'My::Destructor', ); }, qr/Not inlining 'DESTROY' for DestructorChild since it is not inheriting the default Base::Class::DESTROY/, 'got a warning when trying to inline a destructor in a class that inherits an unexpected DESTROY' ); } done_testing; insertion_order.t100644000767000024 157612200352344 17140 0ustar00etherstaff000000000000Moose-2.1005/t/cmopuse strict; use warnings; use Test::More; use Class::MOP; my $Point = Class::MOP::Class->create('Point' => ( version => '0.01', attributes => [ Class::MOP::Attribute->new('x' => ( reader => 'x', init_arg => 'x' )), Class::MOP::Attribute->new('y' => ( accessor => 'y', init_arg => 'y' )), ], methods => { 'new' => sub { my $class = shift; my $instance = $class->meta->new_object(@_); bless $instance => $class; }, 'clear' => sub { my $self = shift; $self->{'x'} = 0; $self->{'y'} = 0; } } )); is($Point->get_attribute('x')->insertion_order, 0, 'Insertion order of Attribute "x"'); is($Point->get_attribute('y')->insertion_order, 1, 'Insertion order of Attribute "y"'); done_testing; instance_inline.t100644000767000024 262412200352344 17070 0ustar00etherstaff000000000000Moose-2.1005/t/cmopuse strict; use warnings; use Test::More; use Test::Fatal; use Class::MOP::Instance; my $C = 'Class::MOP::Instance'; { my $instance = '$self'; my $slot_name = 'foo'; my $value = '$value'; my $class = '$class'; is($C->inline_create_instance($class), 'bless {} => $class', '... got the right code for create_instance'); is($C->inline_get_slot_value($instance, $slot_name), q[$self->{"foo"}], '... got the right code for get_slot_value'); is($C->inline_set_slot_value($instance, $slot_name, $value), q[$self->{"foo"} = $value], '... got the right code for set_slot_value'); is($C->inline_initialize_slot($instance, $slot_name), '', '... got the right code for initialize_slot'); is($C->inline_is_slot_initialized($instance, $slot_name), q[exists $self->{"foo"}], '... got the right code for get_slot_value'); is($C->inline_weaken_slot_value($instance, $slot_name), q[Scalar::Util::weaken( $self->{"foo"} )], '... got the right code for weaken_slot_value'); is($C->inline_strengthen_slot_value($instance, $slot_name), q[$self->{"foo"} = $self->{"foo"}], '... got the right code for strengthen_slot_value'); is($C->inline_rebless_instance_structure($instance, $class), q[bless $self => $class], '... got the right code for rebless_instance_structure'); } done_testing; random_eval_bug.t100644000767000024 141712200352344 17051 0ustar00etherstaff000000000000Moose-2.1005/t/cmopuse strict; use warnings; use Test::More; use Class::MOP; =pod This tests a bug which is fixed in 0.22 by localizing all the $@'s around any evals. This a real pain to track down. Moral of the story: ALWAYS localize your globals :) =cut { package Company; use strict; use warnings; use metaclass; sub new { my ($class) = @_; return bless {} => $class; } sub employees { die "This didnt work"; } sub DESTROY { my $self = shift; foreach my $method ( $self->meta->find_all_methods_by_name('DEMOLISH') ) { $method->{code}->($self); } } } eval { my $c = Company->new(); $c->employees(); }; ok( $@, '... we die correctly with bad args' ); done_testing; lib000755000767000024 012200352344 14143 5ustar00etherstaff000000000000Moose-2.1005/t/cmopBinaryTree.pm100644000767000024 634412200352344 16714 0ustar00etherstaff000000000000Moose-2.1005/t/cmop/lib package BinaryTree; use strict; use warnings; use Carp qw/confess/; use metaclass; our $VERSION = '0.02'; BinaryTree->meta->add_attribute('uid' => ( reader => 'getUID', writer => 'setUID', default => sub { my $instance = shift; ("$instance" =~ /\((.*?)\)$/)[0]; } )); BinaryTree->meta->add_attribute('node' => ( reader => 'getNodeValue', writer => 'setNodeValue', clearer => 'clearNodeValue', init_arg => ':node' )); BinaryTree->meta->add_attribute('parent' => ( predicate => 'hasParent', reader => 'getParent', writer => 'setParent', clearer => 'clearParent', )); BinaryTree->meta->add_attribute('left' => ( predicate => 'hasLeft', clearer => 'clearLeft', reader => 'getLeft', writer => { 'setLeft' => sub { my ($self, $tree) = @_; confess "undef left" unless defined $tree; $tree->setParent($self) if defined $tree; $self->{'left'} = $tree; $self; } }, )); BinaryTree->meta->add_attribute('right' => ( predicate => 'hasRight', clearer => 'clearRight', reader => 'getRight', writer => { 'setRight' => sub { my ($self, $tree) = @_; confess "undef right" unless defined $tree; $tree->setParent($self) if defined $tree; $self->{'right'} = $tree; $self; } } )); sub new { my $class = shift; $class->meta->new_object(':node' => shift); } sub removeLeft { my ($self) = @_; my $left = $self->getLeft(); $left->clearParent; $self->clearLeft; return $left; } sub removeRight { my ($self) = @_; my $right = $self->getRight; $right->clearParent; $self->clearRight; return $right; } sub isLeaf { my ($self) = @_; return (!$self->hasLeft && !$self->hasRight); } sub isRoot { my ($self) = @_; return !$self->hasParent; } sub traverse { my ($self, $func) = @_; $func->($self); $self->getLeft->traverse($func) if $self->hasLeft; $self->getRight->traverse($func) if $self->hasRight; } sub mirror { my ($self) = @_; # swap left for right if( $self->hasLeft && $self->hasRight) { my $left = $self->getLeft; my $right = $self->getRight; $self->setLeft($right); $self->setRight($left); } elsif( $self->hasLeft && !$self->hasRight){ my $left = $self->getLeft; $self->clearLeft; $self->setRight($left); } elsif( !$self->hasLeft && $self->hasRight){ my $right = $self->getRight; $self->clearRight; $self->setLeft($right); } # and recurse $self->getLeft->mirror if $self->hasLeft; $self->getRight->mirror if $self->hasRight; $self; } sub size { my ($self) = @_; my $size = 1; $size += $self->getLeft->size if $self->hasLeft; $size += $self->getRight->size if $self->hasRight; return $size; } sub height { my ($self) = @_; my ($left_height, $right_height) = (0, 0); $left_height = $self->getLeft->height() if $self->hasLeft(); $right_height = $self->getRight->height() if $self->hasRight(); return 1 + (($left_height > $right_height) ? $left_height : $right_height); } 1; MyMetaclassRole.pm100600000767000024 5612200352344 16700 0ustar00etherstaff000000000000Moose-2.1005/t/libpackage MyMetaclassRole; use Moose::Role; 1; Meta000755000767000024 012200352344 14666 5ustar00etherstaff000000000000Moose-2.1005/t/lib/Bar7Trait.pm100600000767000024 15012200352344 16413 0ustar00etherstaff000000000000Moose-2.1005/t/lib/Bar7/Metapackage Bar7::Meta::Trait; use Moose::Role; around _immutable_options => sub { }; no Moose::Role; 1; metaclasses000755000767000024 012200352344 14743 5ustar00etherstaff000000000000Moose-2.1005/tmetarole.t100644000767000024 5451412200352344 17131 0ustar00etherstaff000000000000Moose-2.1005/t/metaclasses#!/usr/bin/perl use strict; use warnings; use lib 't/lib', 'lib'; use Test::More; use Test::Fatal; use Moose::Util::MetaRole; { package My::Meta::Class; use Moose; extends 'Moose::Meta::Class'; } { package Role::Foo; use Moose::Role; has 'foo' => ( is => 'ro', default => 10 ); } { package My::Class; use Moose; } { package My::Role; use Moose::Role; } { Moose::Util::MetaRole::apply_metaroles( for => My::Class->meta, class_metaroles => { class => ['Role::Foo'] }, ); ok( My::Class->meta()->meta()->does_role('Role::Foo'), 'apply Role::Foo to My::Class->meta()' ); is( My::Class->meta()->foo(), 10, '... and call foo() on that meta object' ); } { Moose::Util::MetaRole::apply_metaroles( for => 'My::Class', class_metaroles => { attribute => ['Role::Foo'] }, ); ok( My::Class->meta()->attribute_metaclass()->meta()->does_role('Role::Foo'), q{apply Role::Foo to My::Class->meta()'s attribute metaclass} ); ok( My::Class->meta()->meta()->does_role('Role::Foo'), '... My::Class->meta() still does Role::Foo' ); My::Class->meta()->add_attribute( 'size', is => 'ro' ); is( My::Class->meta()->get_attribute('size')->foo(), 10, '... call foo() on an attribute metaclass object' ); } { Moose::Util::MetaRole::apply_metaroles( for => 'My::Class', class_metaroles => { method => ['Role::Foo'] }, ); ok( My::Class->meta()->method_metaclass()->meta()->does_role('Role::Foo'), q{apply Role::Foo to My::Class->meta()'s method metaclass} ); ok( My::Class->meta()->meta()->does_role('Role::Foo'), '... My::Class->meta() still does Role::Foo' ); ok( My::Class->meta()->attribute_metaclass()->meta()->does_role('Role::Foo'), q{... My::Class->meta()'s attribute metaclass still does Role::Foo} ); My::Class->meta()->add_method( 'bar' => sub { 'bar' } ); is( My::Class->meta()->get_method('bar')->foo(), 10, '... call foo() on a method metaclass object' ); } { Moose::Util::MetaRole::apply_metaroles( for => 'My::Class', class_metaroles => { wrapped_method => ['Role::Foo'] }, ); ok( My::Class->meta()->wrapped_method_metaclass()->meta()->does_role('Role::Foo'), q{apply Role::Foo to My::Class->meta()'s wrapped method metaclass} ); ok( My::Class->meta()->method_metaclass()->meta()->does_role('Role::Foo'), '... My::Class->meta() still does Role::Foo' ); ok( My::Class->meta()->meta()->does_role('Role::Foo'), '... My::Class->meta() still does Role::Foo' ); ok( My::Class->meta()->attribute_metaclass()->meta()->does_role('Role::Foo'), q{... My::Class->meta()'s attribute metaclass still does Role::Foo} ); My::Class->meta()->add_after_method_modifier( 'bar' => sub { 'bar' } ); is( My::Class->meta()->get_method('bar')->foo(), 10, '... call foo() on a wrapped method metaclass object' ); } { Moose::Util::MetaRole::apply_metaroles( for => 'My::Class', class_metaroles => { instance => ['Role::Foo'] }, ); ok( My::Class->meta()->instance_metaclass()->meta()->does_role('Role::Foo'), q{apply Role::Foo to My::Class->meta()'s instance metaclass} ); ok( My::Class->meta()->meta()->does_role('Role::Foo'), '... My::Class->meta() still does Role::Foo' ); ok( My::Class->meta()->attribute_metaclass()->meta()->does_role('Role::Foo'), q{... My::Class->meta()'s attribute metaclass still does Role::Foo} ); ok( My::Class->meta()->method_metaclass()->meta()->does_role('Role::Foo'), q{... My::Class->meta()'s method metaclass still does Role::Foo} ); is( My::Class->meta()->get_meta_instance()->foo(), 10, '... call foo() on an instance metaclass object' ); } { Moose::Util::MetaRole::apply_metaroles( for => 'My::Class', class_metaroles => { constructor => ['Role::Foo'] }, ); ok( My::Class->meta()->constructor_class()->meta()->does_role('Role::Foo'), q{apply Role::Foo to My::Class->meta()'s constructor class} ); ok( My::Class->meta()->meta()->does_role('Role::Foo'), '... My::Class->meta() still does Role::Foo' ); ok( My::Class->meta()->attribute_metaclass()->meta()->does_role('Role::Foo'), q{... My::Class->meta()'s attribute metaclass still does Role::Foo} ); ok( My::Class->meta()->method_metaclass()->meta()->does_role('Role::Foo'), q{... My::Class->meta()'s method metaclass still does Role::Foo} ); ok( My::Class->meta()->instance_metaclass()->meta()->does_role('Role::Foo'), q{... My::Class->meta()'s instance metaclass still does Role::Foo} ); # Actually instantiating the constructor class is too freaking hard! ok( My::Class->meta()->constructor_class()->can('foo'), '... constructor class has a foo method' ); } { Moose::Util::MetaRole::apply_metaroles( for => 'My::Class', class_metaroles => { destructor => ['Role::Foo'] }, ); ok( My::Class->meta()->destructor_class()->meta()->does_role('Role::Foo'), q{apply Role::Foo to My::Class->meta()'s destructor class} ); ok( My::Class->meta()->meta()->does_role('Role::Foo'), '... My::Class->meta() still does Role::Foo' ); ok( My::Class->meta()->attribute_metaclass()->meta()->does_role('Role::Foo'), q{... My::Class->meta()'s attribute metaclass still does Role::Foo} ); ok( My::Class->meta()->method_metaclass()->meta()->does_role('Role::Foo'), q{... My::Class->meta()'s method metaclass still does Role::Foo} ); ok( My::Class->meta()->instance_metaclass()->meta()->does_role('Role::Foo'), q{... My::Class->meta()'s instance metaclass still does Role::Foo} ); ok( My::Class->meta()->constructor_class()->meta()->does_role('Role::Foo'), q{... My::Class->meta()'s constructor class still does Role::Foo} ); # same problem as the constructor class ok( My::Class->meta()->destructor_class()->can('foo'), '... destructor class has a foo method' ); } { Moose::Util::MetaRole::apply_metaroles( for => 'My::Role', role_metaroles => { application_to_class => ['Role::Foo'] }, ); ok( My::Role->meta->application_to_class_class->meta->does_role('Role::Foo'), q{apply Role::Foo to My::Role->meta's application_to_class class} ); is( My::Role->meta->application_to_class_class->new->foo, 10, q{... call foo() on an application_to_class instance} ); } { Moose::Util::MetaRole::apply_metaroles( for => 'My::Role', role_metaroles => { application_to_role => ['Role::Foo'] }, ); ok( My::Role->meta->application_to_role_class->meta->does_role('Role::Foo'), q{apply Role::Foo to My::Role->meta's application_to_role class} ); ok( My::Role->meta->application_to_class_class->meta->does_role('Role::Foo'), q{... My::Role->meta's application_to_class class still does Role::Foo} ); is( My::Role->meta->application_to_role_class->new->foo, 10, q{... call foo() on an application_to_role instance} ); } { Moose::Util::MetaRole::apply_metaroles( for => 'My::Role', role_metaroles => { application_to_instance => ['Role::Foo'] }, ); ok( My::Role->meta->application_to_instance_class->meta->does_role('Role::Foo'), q{apply Role::Foo to My::Role->meta's application_to_instance class} ); ok( My::Role->meta->application_to_role_class->meta->does_role('Role::Foo'), q{... My::Role->meta's application_to_role class still does Role::Foo} ); ok( My::Role->meta->application_to_class_class->meta->does_role('Role::Foo'), q{... My::Role->meta's application_to_class class still does Role::Foo} ); is( My::Role->meta->application_to_instance_class->new->foo, 10, q{... call foo() on an application_to_instance instance} ); } { Moose::Util::MetaRole::apply_base_class_roles( for => 'My::Class', roles => ['Role::Foo'], ); ok( My::Class->meta()->does_role('Role::Foo'), 'apply Role::Foo to My::Class base class' ); is( My::Class->new()->foo(), 10, '... call foo() on a My::Class object' ); } { package My::Class2; use Moose; } { Moose::Util::MetaRole::apply_metaroles( for => 'My::Class2', class_metaroles => { class => ['Role::Foo'], attribute => ['Role::Foo'], method => ['Role::Foo'], instance => ['Role::Foo'], constructor => ['Role::Foo'], destructor => ['Role::Foo'], }, ); ok( My::Class2->meta()->meta()->does_role('Role::Foo'), 'apply Role::Foo to My::Class2->meta()' ); is( My::Class2->meta()->foo(), 10, '... and call foo() on that meta object' ); ok( My::Class2->meta()->attribute_metaclass()->meta()->does_role('Role::Foo'), q{apply Role::Foo to My::Class2->meta()'s attribute metaclass} ); My::Class2->meta()->add_attribute( 'size', is => 'ro' ); is( My::Class2->meta()->get_attribute('size')->foo(), 10, '... call foo() on an attribute metaclass object' ); ok( My::Class2->meta()->method_metaclass()->meta()->does_role('Role::Foo'), q{apply Role::Foo to My::Class2->meta()'s method metaclass} ); My::Class2->meta()->add_method( 'bar' => sub { 'bar' } ); is( My::Class2->meta()->get_method('bar')->foo(), 10, '... call foo() on a method metaclass object' ); ok( My::Class2->meta()->instance_metaclass()->meta()->does_role('Role::Foo'), q{apply Role::Foo to My::Class2->meta()'s instance metaclass} ); is( My::Class2->meta()->get_meta_instance()->foo(), 10, '... call foo() on an instance metaclass object' ); ok( My::Class2->meta()->constructor_class()->meta()->does_role('Role::Foo'), q{apply Role::Foo to My::Class2->meta()'s constructor class} ); ok( My::Class2->meta()->constructor_class()->can('foo'), '... constructor class has a foo method' ); ok( My::Class2->meta()->destructor_class()->meta()->does_role('Role::Foo'), q{apply Role::Foo to My::Class2->meta()'s destructor class} ); ok( My::Class2->meta()->destructor_class()->can('foo'), '... destructor class has a foo method' ); } { package My::Meta; use Moose::Exporter; Moose::Exporter->setup_import_methods( also => 'Moose' ); sub init_meta { shift; my %p = @_; Moose->init_meta( %p, metaclass => 'My::Meta::Class' ); } } { package My::Class3; My::Meta->import(); } { Moose::Util::MetaRole::apply_metaroles( for => 'My::Class3', class_metaroles => { class => ['Role::Foo'] }, ); ok( My::Class3->meta()->meta()->does_role('Role::Foo'), 'apply Role::Foo to My::Class3->meta()' ); is( My::Class3->meta()->foo(), 10, '... and call foo() on that meta object' ); ok( ( grep { $_ eq 'My::Meta::Class' } My::Class3->meta()->meta()->superclasses() ), 'apply_metaroles() does not interfere with metaclass set via Moose->init_meta()' ); } { package Role::Bar; use Moose::Role; has 'bar' => ( is => 'ro', default => 200 ); } { package My::Class4; use Moose; } { Moose::Util::MetaRole::apply_metaroles( for => 'My::Class4', class_metaroles => { class => ['Role::Foo'] }, ); ok( My::Class4->meta()->meta()->does_role('Role::Foo'), 'apply Role::Foo to My::Class4->meta()' ); Moose::Util::MetaRole::apply_metaroles( for => 'My::Class4', class_metaroles => { class => ['Role::Bar'] }, ); ok( My::Class4->meta()->meta()->does_role('Role::Bar'), 'apply Role::Bar to My::Class4->meta()' ); ok( My::Class4->meta()->meta()->does_role('Role::Foo'), '... and My::Class4->meta() still does Role::Foo' ); } { package My::Class5; use Moose; extends 'My::Class'; } { ok( My::Class5->meta()->meta()->does_role('Role::Foo'), q{My::Class5->meta()'s does Role::Foo because it extends My::Class} ); ok( My::Class5->meta()->attribute_metaclass()->meta()->does_role('Role::Foo'), q{My::Class5->meta()'s attribute metaclass also does Role::Foo} ); ok( My::Class5->meta()->method_metaclass()->meta()->does_role('Role::Foo'), q{My::Class5->meta()'s method metaclass also does Role::Foo} ); ok( My::Class5->meta()->instance_metaclass()->meta()->does_role('Role::Foo'), q{My::Class5->meta()'s instance metaclass also does Role::Foo} ); ok( My::Class5->meta()->constructor_class()->meta()->does_role('Role::Foo'), q{My::Class5->meta()'s constructor class also does Role::Foo} ); ok( My::Class5->meta()->destructor_class()->meta()->does_role('Role::Foo'), q{My::Class5->meta()'s destructor class also does Role::Foo} ); } { Moose::Util::MetaRole::apply_metaroles( for => 'My::Class5', class_metaroles => { class => ['Role::Bar'] }, ); ok( My::Class5->meta()->meta()->does_role('Role::Bar'), q{apply Role::Bar My::Class5->meta()} ); ok( My::Class5->meta()->meta()->does_role('Role::Foo'), q{... and My::Class5->meta() still does Role::Foo} ); } { package My::Class6; use Moose; Moose::Util::MetaRole::apply_metaroles( for => 'My::Class6', class_metaroles => { class => ['Role::Bar'] }, ); extends 'My::Class'; } { ok( My::Class6->meta()->meta()->does_role('Role::Bar'), q{apply Role::Bar My::Class6->meta() before extends} ); ok( My::Class6->meta()->meta()->does_role('Role::Foo'), q{... and My::Class6->meta() does Role::Foo because My::Class6 extends My::Class} ); } # This is the hack that used to be needed to work around the # _fix_metaclass_incompatibility problem. You called extends() (which # in turn calls _fix_metaclass_imcompatibility) _before_ you apply # more extensions in the subclass. We wabt to make sure this continues # to work in the future. { package My::Class7; use Moose; # In real usage this would go in a BEGIN block so it happened # before apply_metaroles was called by an extension. extends 'My::Class'; Moose::Util::MetaRole::apply_metaroles( for => 'My::Class7', class_metaroles => { class => ['Role::Bar'] }, ); } { ok( My::Class7->meta()->meta()->does_role('Role::Bar'), q{apply Role::Bar My::Class7->meta() before extends} ); ok( My::Class7->meta()->meta()->does_role('Role::Foo'), q{... and My::Class7->meta() does Role::Foo because My::Class7 extends My::Class} ); } { package My::Class8; use Moose; Moose::Util::MetaRole::apply_metaroles( for => 'My::Class8', class_metaroles => { class => ['Role::Bar'], attribute => ['Role::Bar'], }, ); extends 'My::Class'; } { ok( My::Class8->meta()->meta()->does_role('Role::Bar'), q{apply Role::Bar My::Class8->meta() before extends} ); ok( My::Class8->meta()->meta()->does_role('Role::Foo'), q{... and My::Class8->meta() does Role::Foo because My::Class8 extends My::Class} ); ok( My::Class8->meta()->attribute_metaclass->meta()->does_role('Role::Bar'), q{apply Role::Bar to My::Class8->meta()->attribute_metaclass before extends} ); ok( My::Class8->meta()->attribute_metaclass->meta()->does_role('Role::Foo'), q{... and My::Class8->meta()->attribute_metaclass does Role::Foo because My::Class8 extends My::Class} ); } { package My::Class9; use Moose; Moose::Util::MetaRole::apply_metaroles( for => 'My::Class9', class_metaroles => { attribute => ['Role::Bar'] }, ); extends 'My::Class'; } { ok( My::Class9->meta()->meta()->does_role('Role::Foo'), q{... and My::Class9->meta() does Role::Foo because My::Class9 extends My::Class} ); ok( My::Class9->meta()->attribute_metaclass->meta()->does_role('Role::Bar'), q{apply Role::Bar to My::Class9->meta()->attribute_metaclass before extends} ); ok( My::Class9->meta()->attribute_metaclass->meta()->does_role('Role::Foo'), q{... and My::Class9->meta()->attribute_metaclass does Role::Foo because My::Class9 extends My::Class} ); } # This tests applying meta roles to a metaclass's metaclass. This is # completely insane, but is exactly what happens with # Fey::Meta::Class::Table. It's a subclass of Moose::Meta::Class # itself, and then it _uses_ MooseX::ClassAttribute, so the metaclass # for Fey::Meta::Class::Table does a role. # # At one point this caused a metaclass incompatibility error down # below, when we applied roles to the metaclass of My::Class10. It's # all madness but as long as the tests pass we're happy. { package My::Meta::Class2; use Moose; extends 'Moose::Meta::Class'; Moose::Util::MetaRole::apply_metaroles( for => 'My::Meta::Class2', class_metaroles => { class => ['Role::Foo'] }, ); } { package My::Object; use Moose; extends 'Moose::Object'; } { package My::Meta2; use Moose::Exporter; Moose::Exporter->setup_import_methods( also => 'Moose' ); sub init_meta { shift; my %p = @_; Moose->init_meta( %p, metaclass => 'My::Meta::Class2', base_class => 'My::Object', ); } } { package My::Class10; My::Meta2->import; Moose::Util::MetaRole::apply_metaroles( for => 'My::Class10', class_metaroles => { class => ['Role::Bar'] }, ); } { ok( My::Class10->meta()->meta()->meta()->does_role('Role::Foo'), q{My::Class10->meta()->meta() does Role::Foo } ); ok( My::Class10->meta()->meta()->does_role('Role::Bar'), q{My::Class10->meta()->meta() does Role::Bar } ); ok( My::Class10->meta()->isa('My::Meta::Class2'), q{... and My::Class10->meta still isa(My::Meta::Class2)} ); ok( My::Class10->isa('My::Object'), q{... and My::Class10 still isa(My::Object)} ); } { package My::Constructor; use base 'Moose::Meta::Method::Constructor'; } { package My::Class11; use Moose; __PACKAGE__->meta->constructor_class('My::Constructor'); Moose::Util::MetaRole::apply_metaroles( for => 'My::Class11', class_metaroles => { class => ['Role::Foo'] }, ); } { ok( My::Class11->meta()->meta()->does_role('Role::Foo'), q{My::Class11->meta()->meta() does Role::Foo } ); is( My::Class11->meta()->constructor_class, 'My::Constructor', q{... and explicitly set constructor_class value is unchanged)} ); } { package ExportsMoose; Moose::Exporter->setup_import_methods( also => 'Moose', ); sub init_meta { shift; my %p = @_; Moose->init_meta(%p); return Moose::Util::MetaRole::apply_metaroles( for => $p{for_class}, # Causes us to recurse through init_meta, as we have to # load MyMetaclassRole from disk. class_metaroles => { class => [qw/MyMetaclassRole/] }, ); } } is( exception { package UsesExportedMoose; ExportsMoose->import; }, undef, 'import module which loads a role from disk during init_meta' ); { package Foo::Meta::Role; use Moose::Role; } { package Foo::Role; Moose::Exporter->setup_import_methods( also => 'Moose::Role', ); sub init_meta { shift; my %p = @_; Moose::Role->init_meta(%p); return Moose::Util::MetaRole::apply_metaroles( for => $p{for_class}, role_metaroles => { method => ['Foo::Meta::Role'] }, ); } } { package Role::Baz; Foo::Role->import; sub bla {} } { package My::Class12; use Moose; with( 'Role::Baz' ); } { ok( My::Class12->meta->does_role( 'Role::Baz' ), 'role applied' ); my $method = My::Class12->meta->get_method( 'bla' ); ok( $method->meta->does_role( 'Foo::Meta::Role' ), 'method_metaclass_role applied' ); } { package Parent; use Moose; Moose::Util::MetaRole::apply_metaroles( for => __PACKAGE__, class_metaroles => { constructor => ['Role::Foo'] }, ); } { package Child; use Moose; extends 'Parent'; } { ok( Parent->meta->constructor_class->meta->can('does_role') && Parent->meta->constructor_class->meta->does_role('Role::Foo'), 'Parent constructor class has metarole from Parent' ); ok( Child->meta->constructor_class->meta->can('does_role') && Child->meta->constructor_class->meta->does_role( 'Role::Foo'), 'Child constructor class has metarole from Parent' ); } { package NotMoosey; use metaclass; } { like( exception { Moose::Util::MetaRole::apply_metaroles( for => 'Does::Not::Exist', class_metaroles => { class => ['Role::Foo'] }, ); }, qr/When using Moose::Util::MetaRole.+You passed Does::Not::Exist.+Maybe you need to call.+/, 'useful error when apply metaroles to a class without a metaclass' ); like( exception { Moose::Util::MetaRole::apply_metaroles( for => 'NotMoosey', class_metaroles => { class => ['Role::Foo'] }, ); }, qr/When using Moose::Util::MetaRole.+You passed NotMoosey.+we resolved this to a Class::MOP::Class object.+/, 'useful error when using apply metaroles to a class with a Class::MOP::Class metaclass' ); like( exception { Moose::Util::MetaRole::apply_base_class_roles( for => 'NotMoosey', roles => { class => ['Role::Foo'] }, ); }, qr/When using Moose::Util::MetaRole.+You passed NotMoosey.+we resolved this to a Class::MOP::Class object.+/, 'useful error when applying base class to roles to a non-Moose class' ); like( exception { Moose::Util::MetaRole::apply_base_class_roles( for => 'My::Role', roles => { class => ['Role::Foo'] }, ); }, qr/You can only apply base class roles to a Moose class.+/, 'useful error when applying base class to roles to a non-Moose class' ); } done_testing; role_composite.t100644000767000024 340412200352344 17134 0ustar00etherstaff000000000000Moose-2.1005/t/roles#!/usr/bin/perl use strict; use warnings; use Test::More; use Test::Fatal; use Moose::Meta::Role::Application::RoleSummation; use Moose::Meta::Role::Composite; { package Role::Foo; use Moose::Role; package Role::Bar; use Moose::Role; package Role::Baz; use Moose::Role; package Role::Gorch; use Moose::Role; } { my $c = Moose::Meta::Role::Composite->new( roles => [ Role::Foo->meta, Role::Bar->meta, Role::Baz->meta, ] ); isa_ok($c, 'Moose::Meta::Role::Composite'); is($c->name, 'Role::Foo|Role::Bar|Role::Baz', '... got the composite role name'); is_deeply($c->get_roles, [ Role::Foo->meta, Role::Bar->meta, Role::Baz->meta, ], '... got the right roles'); ok($c->does_role($_), '... our composite does the role ' . $_) for qw( Role::Foo Role::Bar Role::Baz ); is( exception { Moose::Meta::Role::Application::RoleSummation->new->apply($c); }, undef, '... this composed okay' ); ##... now nest 'em { my $c2 = Moose::Meta::Role::Composite->new( roles => [ $c, Role::Gorch->meta, ] ); isa_ok($c2, 'Moose::Meta::Role::Composite'); is($c2->name, 'Role::Foo|Role::Bar|Role::Baz|Role::Gorch', '... got the composite role name'); is_deeply($c2->get_roles, [ $c, Role::Gorch->meta, ], '... got the right roles'); ok($c2->does_role($_), '... our composite does the role ' . $_) for qw( Role::Foo Role::Bar Role::Baz Role::Gorch ); } } done_testing; role_consumers.t100644000767000024 141712200352344 17152 0ustar00etherstaff000000000000Moose-2.1005/t/rolesuse strict; use warnings; use Test::More; { package Foo::Role; use Moose::Role; } { package Bar::Role; use Moose::Role; } { package Foo; use Moose; with 'Foo::Role'; } { package Bar; use Moose; extends 'Foo'; with 'Bar::Role'; } { package FooBar; use Moose; with 'Foo::Role', 'Bar::Role'; } { package Foo::Role::User; use Moose::Role; with 'Foo::Role'; } { package Foo::User; use Moose; with 'Foo::Role::User'; } is_deeply([sort Foo::Role->meta->consumers], ['Bar', 'Foo', 'Foo::Role::User', 'Foo::User', 'FooBar']); is_deeply([sort Bar::Role->meta->consumers], ['Bar', 'FooBar']); is_deeply([sort Foo::Role::User->meta->consumers], ['Foo::User']); done_testing; role_exclusion.t100644000767000024 662212200352344 17150 0ustar00etherstaff000000000000Moose-2.1005/t/roles#!/usr/bin/perl use strict; use warnings; use Test::More; use Test::Fatal; =pod The idea and examples for this feature are taken from the Fortress spec. http://research.sun.com/projects/plrg/fortress0903.pdf trait OrganicMolecule extends Molecule excludes { InorganicMolecule } end trait InorganicMolecule extends Molecule end =cut { package Molecule; use Moose::Role; package Molecule::Organic; use Moose::Role; with 'Molecule'; excludes 'Molecule::Inorganic'; package Molecule::Inorganic; use Moose::Role; with 'Molecule'; } ok(Molecule::Organic->meta->excludes_role('Molecule::Inorganic'), '... Molecule::Organic exludes Molecule::Inorganic'); is_deeply( [ Molecule::Organic->meta->get_excluded_roles_list() ], [ 'Molecule::Inorganic' ], '... Molecule::Organic exludes Molecule::Inorganic'); =pod Check some basic conflicts when combining the roles into the same class =cut { package My::Test1; use Moose; ::is( ::exception { with 'Molecule::Organic'; }, undef, '... adding the role (w/ excluded roles) okay' ); package My::Test2; use Moose; ::like( ::exception { with 'Molecule::Organic', 'Molecule::Inorganic'; }, qr/Conflict detected: Role Molecule::Organic excludes role 'Molecule::Inorganic'/, '... adding the role w/ excluded role conflict dies okay' ); package My::Test3; use Moose; ::is( ::exception { with 'Molecule::Organic'; }, undef, '... adding the role (w/ excluded roles) okay' ); ::like( ::exception { with 'Molecule::Inorganic'; }, qr/Conflict detected: My::Test3 excludes role 'Molecule::Inorganic'/, '... adding the role w/ excluded role conflict dies okay' ); } ok(My::Test1->does('Molecule::Organic'), '... My::Test1 does Molecule::Organic'); ok(My::Test1->does('Molecule'), '... My::Test1 does Molecule'); ok(My::Test1->meta->excludes_role('Molecule::Inorganic'), '... My::Test1 excludes Molecule::Organic'); ok(!My::Test2->does('Molecule::Organic'), '... ! My::Test2 does Molecule::Organic'); ok(!My::Test2->does('Molecule::Inorganic'), '... ! My::Test2 does Molecule::Inorganic'); ok(My::Test3->does('Molecule::Organic'), '... My::Test3 does Molecule::Organic'); ok(My::Test3->does('Molecule'), '... My::Test1 does Molecule'); ok(My::Test3->meta->excludes_role('Molecule::Inorganic'), '... My::Test3 excludes Molecule::Organic'); ok(!My::Test3->does('Molecule::Inorganic'), '... ! My::Test3 does Molecule::Inorganic'); =pod Check some basic conflicts when combining the roles into the a superclass =cut { package Methane; use Moose; with 'Molecule::Organic'; package My::Test4; use Moose; extends 'Methane'; ::like( ::exception { with 'Molecule::Inorganic'; }, qr/Conflict detected: My::Test4 excludes role \'Molecule::Inorganic\'/, '... cannot add exculded role into class which extends Methane' ); } ok(Methane->does('Molecule::Organic'), '... Methane does Molecule::Organic'); ok(My::Test4->isa('Methane'), '... My::Test4 isa Methane'); ok(My::Test4->does('Molecule::Organic'), '... My::Test4 does Molecule::Organic'); ok(My::Test4->meta->does_role('Molecule::Organic'), '... My::Test4 meat does_role Molecule::Organic'); ok(My::Test4->meta->excludes_role('Molecule::Inorganic'), '... My::Test4 meta excludes Molecule::Organic'); ok(!My::Test4->does('Molecule::Inorganic'), '... My::Test4 does Molecule::Inorganic'); done_testing; author000755000767000024 012200352344 14131 5ustar00etherstaff000000000000Moose-2.1005/xtmemory_leaks.t100644000767000024 557112200352344 17155 0ustar00etherstaff000000000000Moose-2.1005/xt/authoruse strict; use warnings; use Test::More; use Test::LeakTrace 0.01; use Test::Memory::Cycle; use Moose (); use Moose::Util qw( apply_all_roles ); use Moose::Util::TypeConstraints; { package MyRole; use Moose::Role; sub myname { "I'm a role" } } no_leaks_ok( sub { Moose::Meta::Class->create_anon_class->new_object; }, 'anonymous class with no roles is leak-free' ); no_leaks_ok( sub { Moose::Meta::Role->initialize('MyRole2'); }, 'Moose::Meta::Role->initialize is leak-free' ); no_leaks_ok( sub { Moose::Meta::Class->create('MyClass2')->new_object; }, 'creating named class is leak-free' ); { local $TODO = 'role application leaks because we end up applying the role more than once to the meta object'; no_leaks_ok( sub { Moose::Meta::Class->create( 'MyClass', roles => ['MyRole'] ); }, 'named class with roles is leak-free' ); no_leaks_ok( sub { Moose::Meta::Role->create( 'MyRole2', roles => ['MyRole'] ); }, 'named role with roles is leak-free' ); } no_leaks_ok( sub { my $object = Moose::Meta::Class->create('MyClass2')->new_object; apply_all_roles( $object, 'MyRole' ); }, 'applying role to an instance is leak-free' ); no_leaks_ok( sub { Moose::Meta::Role->create_anon_role; }, 'anonymous role is leak-free' ); { # fixing this leak currently triggers a bug in Carp # we can un-TODO once that fix goes in allowing the leak # in Eval::Closure to be fixed local $TODO = 'Eval::Closure leaks a bit at the moment'; no_leaks_ok( sub { my $meta = Moose::Meta::Class->create_anon_class; $meta->make_immutable; }, 'making an anon class immutable is leak-free' ); } { my $meta3 = Moose::Meta::Class->create('MyClass3'); memory_cycle_ok( $meta3, 'named metaclass object is cycle-free' ); memory_cycle_ok( $meta3->new_object, 'MyClass3 object is cycle-free' ); my $anon_class = Moose::Meta::Class->create_anon_class; memory_cycle_ok($anon_class, 'anon metaclass object is cycle-free' ); memory_cycle_ok( $anon_class->new_object, 'object from anon metaclass is cycle-free' ); $anon_class->make_immutable; memory_cycle_ok($anon_class, 'immutable anon metaclass object is cycle-free' ); memory_cycle_ok( $anon_class->new_object, 'object from immutable anon metaclass is cycle-free' ); my $anon_role = Moose::Meta::Role->create_anon_role; memory_cycle_ok($anon_role, 'anon role meta object is cycle-free' ); } { my $Str = find_type_constraint('Str'); my $Undef = find_type_constraint('Undef'); my $Str_or_Undef = Moose::Meta::TypeConstraint::Union->new( type_constraints => [ $Str, $Undef ] ); memory_cycle_ok($Str_or_Undef, 'union types do not leak'); } done_testing; moose_bench.pl100700000767000024 1063412200352344 17304 0ustar00etherstaff000000000000Moose-2.1005/benchmarks#!/usr/bin/env perl use strict; use warnings; use Time::HiRes 'time'; use List::Util 'sum'; use IPC::System::Simple 'system'; use autodie; use Parse::BACKPAN::Packages; use LWP::Simple; use Archive::Tar; use File::Slurp 'slurp'; my $backpan = Parse::BACKPAN::Packages->new; my @cmops = $backpan->distributions('Class-MOP'); my @mooses = $backpan->distributions('Moose'); my $cmop_version = 0; my $cmop_dir; my $base = "http://backpan.cpan.org/"; my %time; my %mem; open my $output, ">", "moose_bench.txt"; for my $moose (@mooses) { my $moose_dir = build($moose); # Find the CMOP dependency my $makefile = slurp("$moose_dir/Makefile.PL"); my ($cmop_dep) = $makefile =~ /Class::MOP.*?([0-9._]+)/ or die "Unable to find Class::MOP version dependency in $moose_dir/Makefile.PL"; # typo? $cmop_dep = '0.64_07' if $cmop_dep eq '0.6407'; # nonexistent dev releases? $cmop_dep = '0.79' if $cmop_dep eq '0.78_02'; $cmop_dep = '0.83' if $cmop_dep eq '0.82_01'; bump_cmop($cmop_dep, $moose); warn "Building $moose_dir"; eval { system("(cd '$moose_dir' && '$^X' '-I$cmop_dir/lib' Makefile.PL && make && sudo make install) >/dev/null"); my @times; for (1 .. 5) { my $start = time; system( $^X, "-I$moose_dir/lib", "-I$cmop_dir/lib", '-e', 'package Class; use Moose;', ); push @times, time - $start; } $time{$moose->version} = sum(@times) / @times; $mem{$moose->version} = qx[$^X -I$moose_dir/lib -I$cmop_dir/lib -MGTop -e 'my (\$gtop, \$before); BEGIN { \$gtop = GTop->new; \$before = \$gtop->proc_mem(\$\$)->size; } package Class; use Moose; print \$gtop->proc_mem(\$\$)->size - \$before']; my $line = sprintf "%7s: %0.4f (%s), %d bytes\n", $moose->version, $time{$moose->version}, join(', ', map { sprintf "%0.4f", $_ } @times), $mem{$moose->version}; print $output $line; }; warn $@ if $@; } require Chart::Clicker; require Chart::Clicker::Data::Series; require Chart::Clicker::Data::DataSet; my @versions = sort keys %time; my @startups = map { $time{$_} } @versions; my @memories = map { int($mem{$_} / 1024) } @versions; my @keys = (0..$#versions); my $cc = Chart::Clicker->new(width => 900, height => 400); my $sutime = Chart::Clicker::Data::Series->new( values => \@startups, keys => \@keys, name => 'Startup Time', ); my $def = $cc->get_context('default'); $def->domain_axis->tick_values(\@keys); $def->domain_axis->tick_labels(\@versions); $def->domain_axis->tick_label_angle(1.57); $def->domain_axis->tick_font->size(8); $def->range_axis->fudge_amount('0.05'); my $context = Chart::Clicker::Context->new(name => 'memory'); $context->range_axis->tick_values([qw(1024 2048 3072 4096 5120)]); $context->range_axis->format('%d'); $context->domain_axis->hidden(1); $context->range_axis->fudge_amount('0.05'); $cc->add_to_contexts($context); my $musage = Chart::Clicker::Data::Series->new( values => \@memories, keys => \@keys, name => 'Memory Usage (kb)' ); my $ds1 = Chart::Clicker::Data::DataSet->new(series => [ $sutime ]); my $ds2 = Chart::Clicker::Data::DataSet->new(series => [ $musage ]); $ds2->context('memory'); $cc->add_to_datasets($ds1); $cc->add_to_datasets($ds2); $cc->write_output('moose_bench.png'); sub bump_cmop { my $expected = shift; my $moose = shift; return $cmop_dir if $cmop_version eq $expected; my @orig_cmops = @cmops; shift @cmops until !@cmops || $cmops[0]->version eq $expected; die "Ran out of cmops, wanted $expected for " . $moose->distvname . " (had " . join(', ', map { $_->version } @orig_cmops) . ")" if !@cmops; $cmop_version = $cmops[0]->version; $cmop_dir = build($cmops[0]); warn "Building $cmop_dir"; system("(cd '$cmop_dir' && '$^X' Makefile.PL && make && sudo make install) >/dev/null"); return $cmop_dir; } sub build { my $dist = shift; my $distvname = $dist->distvname; return $distvname if -d $distvname; warn "Downloading $distvname"; my $tarball = get($base . $dist->prefix); open my $handle, '<', \$tarball; my $tar = Archive::Tar->new; $tar->read($handle); $tar->extract; my ($arbitrary_file) = $tar->list_files; (my $directory = $arbitrary_file) =~ s{/.*}{}; return $directory; } ExtractInlineTests.pm100644000767000024 221412200352344 17236 0ustar00etherstaff000000000000Moose-2.1005/incpackage inc::ExtractInlineTests; use Moose; with 'Dist::Zilla::Role::FileGatherer'; use File::Basename qw( basename ); use File::Find::Rule; use File::Spec; use File::Temp qw( tempdir ); use inc::MyInline; use Test::Inline; sub gather_files { my $self = shift; my $arg = shift; my $inline = Test::Inline->new( verbose => 0, ExtractHandler => 'My::Extract', ContentHandler => 'My::Content', OutputHandler => My::Output->new($self), ); for my $pod ( File::Find::Rule->file->name(qr/\.pod$/)->in('lib/Moose/Cookbook') ) { $inline->add($pod); } $inline->save; } { package My::Output; sub new { my $class = shift; my $dzil = shift; return bless { dzil => $dzil }, $class; } sub write { my $self = shift; my $name = shift; my $content = shift; $name =~ s/^moose_cookbook_//; $self->{dzil}->add_file( Dist::Zilla::File::InMemory->new( name => "t/recipes/$name", content => $content, ) ); return 1; } } 1; Instance.pm100644000767000024 3170412200352344 16731 0ustar00etherstaff000000000000Moose-2.1005/lib/Class/MOP package Class::MOP::Instance; BEGIN { $Class::MOP::Instance::AUTHORITY = 'cpan:STEVAN'; } { $Class::MOP::Instance::VERSION = '2.1005'; } use strict; use warnings; use Scalar::Util 'isweak', 'weaken', 'blessed'; use base 'Class::MOP::Object'; # make this not a valid method name, to avoid (most) attribute conflicts my $RESERVED_MOP_SLOT = '<>'; sub BUILDARGS { my ($class, @args) = @_; if ( @args == 1 ) { unshift @args, "associated_metaclass"; } elsif ( @args >= 2 && blessed($args[0]) && $args[0]->isa("Class::MOP::Class") ) { # compat mode my ( $meta, @attrs ) = @args; @args = ( associated_metaclass => $meta, attributes => \@attrs ); } my %options = @args; # FIXME lazy_build $options{slots} ||= [ map { $_->slots } @{ $options{attributes} || [] } ]; $options{slot_hash} = { map { $_ => undef } @{ $options{slots} } }; # FIXME lazy_build return \%options; } sub new { my $class = shift; my $options = $class->BUILDARGS(@_); # FIXME replace with a proper constructor my $instance = $class->_new(%$options); # FIXME weak_ref => 1, weaken($instance->{'associated_metaclass'}); return $instance; } sub _new { my $class = shift; return Class::MOP::Class->initialize($class)->new_object(@_) if $class ne __PACKAGE__; my $params = @_ == 1 ? $_[0] : {@_}; return bless { # NOTE: # I am not sure that it makes # sense to pass in the meta # The ideal would be to just # pass in the class name, but # that is placing too much of # an assumption on bless(), # which is *probably* a safe # assumption,.. but you can # never tell <:) 'associated_metaclass' => $params->{associated_metaclass}, 'attributes' => $params->{attributes}, 'slots' => $params->{slots}, 'slot_hash' => $params->{slot_hash}, } => $class; } sub _class_name { $_[0]->{_class_name} ||= $_[0]->associated_metaclass->name } sub create_instance { my $self = shift; bless {}, $self->_class_name; } sub clone_instance { my ($self, $instance) = @_; my $clone = $self->create_instance; for my $attr ($self->get_all_attributes) { next unless $attr->has_value($instance); for my $slot ($attr->slots) { my $val = $self->get_slot_value($instance, $slot); $self->set_slot_value($clone, $slot, $val); $self->weaken_slot_value($clone, $slot) if $self->slot_value_is_weak($instance, $slot); } } $self->_set_mop_slot($clone, $self->_get_mop_slot($instance)) if $self->_has_mop_slot($instance); return $clone; } # operations on meta instance sub get_all_slots { my $self = shift; return @{$self->{'slots'}}; } sub get_all_attributes { my $self = shift; return @{$self->{attributes}}; } sub is_valid_slot { my ($self, $slot_name) = @_; exists $self->{'slot_hash'}->{$slot_name}; } # operations on created instances sub get_slot_value { my ($self, $instance, $slot_name) = @_; $instance->{$slot_name}; } sub set_slot_value { my ($self, $instance, $slot_name, $value) = @_; $instance->{$slot_name} = $value; } sub initialize_slot { my ($self, $instance, $slot_name) = @_; return; } sub deinitialize_slot { my ( $self, $instance, $slot_name ) = @_; delete $instance->{$slot_name}; } sub initialize_all_slots { my ($self, $instance) = @_; foreach my $slot_name ($self->get_all_slots) { $self->initialize_slot($instance, $slot_name); } } sub deinitialize_all_slots { my ($self, $instance) = @_; foreach my $slot_name ($self->get_all_slots) { $self->deinitialize_slot($instance, $slot_name); } } sub is_slot_initialized { my ($self, $instance, $slot_name, $value) = @_; exists $instance->{$slot_name}; } sub weaken_slot_value { my ($self, $instance, $slot_name) = @_; weaken $instance->{$slot_name}; } sub slot_value_is_weak { my ($self, $instance, $slot_name) = @_; isweak $instance->{$slot_name}; } sub strengthen_slot_value { my ($self, $instance, $slot_name) = @_; $self->set_slot_value($instance, $slot_name, $self->get_slot_value($instance, $slot_name)); } sub rebless_instance_structure { my ($self, $instance, $metaclass) = @_; # we use $_[1] here because of t/cmop/rebless_overload.t regressions # on 5.8.8 bless $_[1], $metaclass->name; } sub is_dependent_on_superclasses { return; # for meta instances that require updates on inherited slot changes } sub _get_mop_slot { my ($self, $instance) = @_; $self->get_slot_value($instance, $RESERVED_MOP_SLOT); } sub _has_mop_slot { my ($self, $instance) = @_; $self->is_slot_initialized($instance, $RESERVED_MOP_SLOT); } sub _set_mop_slot { my ($self, $instance, $value) = @_; $self->set_slot_value($instance, $RESERVED_MOP_SLOT, $value); } sub _clear_mop_slot { my ($self, $instance) = @_; $self->deinitialize_slot($instance, $RESERVED_MOP_SLOT); } # inlinable operation snippets sub is_inlinable { 1 } sub inline_create_instance { my ($self, $class_variable) = @_; 'bless {} => ' . $class_variable; } sub inline_slot_access { my ($self, $instance, $slot_name) = @_; sprintf q[%s->{"%s"}], $instance, quotemeta($slot_name); } sub inline_get_is_lvalue { 1 } sub inline_get_slot_value { my ($self, $instance, $slot_name) = @_; $self->inline_slot_access($instance, $slot_name); } sub inline_set_slot_value { my ($self, $instance, $slot_name, $value) = @_; $self->inline_slot_access($instance, $slot_name) . " = $value", } sub inline_initialize_slot { my ($self, $instance, $slot_name) = @_; return ''; } sub inline_deinitialize_slot { my ($self, $instance, $slot_name) = @_; "delete " . $self->inline_slot_access($instance, $slot_name); } sub inline_is_slot_initialized { my ($self, $instance, $slot_name) = @_; "exists " . $self->inline_slot_access($instance, $slot_name); } sub inline_weaken_slot_value { my ($self, $instance, $slot_name) = @_; sprintf "Scalar::Util::weaken( %s )", $self->inline_slot_access($instance, $slot_name); } sub inline_strengthen_slot_value { my ($self, $instance, $slot_name) = @_; $self->inline_set_slot_value($instance, $slot_name, $self->inline_slot_access($instance, $slot_name)); } sub inline_rebless_instance_structure { my ($self, $instance, $class_variable) = @_; "bless $instance => $class_variable"; } sub _inline_get_mop_slot { my ($self, $instance) = @_; $self->inline_get_slot_value($instance, $RESERVED_MOP_SLOT); } sub _inline_set_mop_slot { my ($self, $instance, $value) = @_; $self->inline_set_slot_value($instance, $RESERVED_MOP_SLOT, $value); } sub _inline_clear_mop_slot { my ($self, $instance) = @_; $self->inline_deinitialize_slot($instance, $RESERVED_MOP_SLOT); } 1; # ABSTRACT: Instance Meta Object __END__ =pod =head1 NAME Class::MOP::Instance - Instance Meta Object =head1 VERSION version 2.1005 =head1 DESCRIPTION The Instance Protocol controls the creation of object instances, and the storage of attribute values in those instances. Using this API directly in your own code violates encapsulation, and we recommend that you use the appropriate APIs in L and L instead. Those APIs in turn call the methods in this class as appropriate. This class also participates in generating inlined code by providing snippets of code to access an object instance. =head1 METHODS =head2 Object construction =over 4 =item B<< Class::MOP::Instance->new(%options) >> This method creates a new meta-instance object. It accepts the following keys in C<%options>: =over 8 =item * associated_metaclass The L object for which instances will be created. =item * attributes An array reference of L objects. These are the attributes which can be stored in each instance. =back =back =head2 Creating and altering instances =over 4 =item B<< $metainstance->create_instance >> This method returns a reference blessed into the associated metaclass's class. The default is to use a hash reference. Subclasses can override this. =item B<< $metainstance->clone_instance($instance) >> Given an instance, this method creates a new object by making I clone of the original. =back =head2 Introspection =over 4 =item B<< $metainstance->associated_metaclass >> This returns the L object associated with the meta-instance object. =item B<< $metainstance->get_all_slots >> This returns a list of slot names stored in object instances. In almost all cases, slot names correspond directly attribute names. =item B<< $metainstance->is_valid_slot($slot_name) >> This will return true if C<$slot_name> is a valid slot name. =item B<< $metainstance->get_all_attributes >> This returns a list of attributes corresponding to the attributes passed to the constructor. =back =head2 Operations on Instance Structures It's important to understand that the meta-instance object is a different entity from the actual instances it creates. For this reason, any operations on the C<$instance_structure> always require that the object instance be passed to the method. =over 4 =item B<< $metainstance->get_slot_value($instance_structure, $slot_name) >> =item B<< $metainstance->set_slot_value($instance_structure, $slot_name, $value) >> =item B<< $metainstance->initialize_slot($instance_structure, $slot_name) >> =item B<< $metainstance->deinitialize_slot($instance_structure, $slot_name) >> =item B<< $metainstance->initialize_all_slots($instance_structure) >> =item B<< $metainstance->deinitialize_all_slots($instance_structure) >> =item B<< $metainstance->is_slot_initialized($instance_structure, $slot_name) >> =item B<< $metainstance->weaken_slot_value($instance_structure, $slot_name) >> =item B<< $metainstance->slot_value_is_weak($instance_structure, $slot_name) >> =item B<< $metainstance->strengthen_slot_value($instance_structure, $slot_name) >> =item B<< $metainstance->rebless_instance_structure($instance_structure, $new_metaclass) >> The exact details of what each method does should be fairly obvious from the method name. =back =head2 Inlinable Instance Operations =over 4 =item B<< $metainstance->is_inlinable >> This is a boolean that indicates whether or not slot access operations can be inlined. By default it is true, but subclasses can override this. =item B<< $metainstance->inline_create_instance($class_variable) >> This method expects a string that, I, will become a class name. This would literally be something like C<'$class'>, not an actual class name. It returns a snippet of code that creates a new object for the class. This is something like C< bless {}, $class_name >. =item B<< $metainstance->inline_get_is_lvalue >> Returns whether or not C is a valid lvalue. This can be used to do extra optimizations when generating inlined methods. =item B<< $metainstance->inline_slot_access($instance_variable, $slot_name) >> =item B<< $metainstance->inline_get_slot_value($instance_variable, $slot_name) >> =item B<< $metainstance->inline_set_slot_value($instance_variable, $slot_name, $value) >> =item B<< $metainstance->inline_initialize_slot($instance_variable, $slot_name) >> =item B<< $metainstance->inline_deinitialize_slot($instance_variable, $slot_name) >> =item B<< $metainstance->inline_is_slot_initialized($instance_variable, $slot_name) >> =item B<< $metainstance->inline_weaken_slot_value($instance_variable, $slot_name) >> =item B<< $metainstance->inline_strengthen_slot_value($instance_variable, $slot_name) >> These methods all expect two arguments. The first is the name of a variable, than when inlined, will represent the object instance. Typically this will be a literal string like C<'$_[0]'>. The second argument is a slot name. The method returns a snippet of code that, when inlined, performs some operation on the instance. =item B<< $metainstance->inline_rebless_instance_structure($instance_variable, $class_variable) >> This takes the name of a variable that will, when inlined, represent the object instance, and the name of a variable that will represent the class to rebless into, and returns code to rebless an instance into a class. =back =head2 Introspection =over 4 =item B<< Class::MOP::Instance->meta >> This will return a L instance for this class. It should also be noted that L will actually bootstrap this module by installing a number of attribute meta-objects into its metaclass. =back =head1 AUTHOR Moose is maintained by the Moose Cabal, along with the help of many contributors. See L and L for details. =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2013 by Infinity Interactive, Inc.. This is free software; you can redistribute it and/or modify it under the same terms as the Perl 5 programming language system itself. =cut Unsweetened.pod100644000767000024 145712200352344 17165 0ustar00etherstaff000000000000Moose-2.1005/lib/Moosepackage Moose::Unsweetened; # ABSTRACT: Moved to Moose::Manual::Unsweetened, so go read that __END__ =pod =head1 NAME Moose::Unsweetened - Moved to Moose::Manual::Unsweetened, so go read that =head1 VERSION version 2.1005 =head1 DESCRIPTION This document has been moved to L. This POD document still exists for the benefit of anyone out there who might've linked to it in the past. =head1 AUTHOR Moose is maintained by the Moose Cabal, along with the help of many contributors. See L and L for details. =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2013 by Infinity Interactive, Inc.. This is free software; you can redistribute it and/or modify it under the same terms as the Perl 5 programming language system itself. =cut attributes000755000767000024 012200352344 14625 5ustar00etherstaff000000000000Moose-2.1005/tbad_coerce.t100644000767000024 137312200352344 17224 0ustar00etherstaff000000000000Moose-2.1005/t/attributesuse strict; use warnings; use Test::More; use Test::Requires { 'Test::Output' => '0.01', # skip all if not installed }; { package Foo; use Moose; ::stderr_like{ has foo => ( is => 'ro', isa => 'Str', coerce => 1, ); } qr/\QYou cannot coerce an attribute (foo) unless its type (Str) has a coercion/, 'Cannot coerce unless the type has a coercion'; ::stderr_like{ has bar => ( is => 'ro', isa => 'Str', coerce => 1, ); } qr/\QYou cannot coerce an attribute (bar) unless its type (Str) has a coercion/, 'Cannot coerce unless the type has a coercion - different attribute'; } done_testing; clone_weak.t100644000767000024 734612200352344 17273 0ustar00etherstaff000000000000Moose-2.1005/t/attributesuse strict; use warnings; use Test::More; { package Foo; use Moose; has bar => ( is => 'ro', weak_ref => 1, ); } { package MyScopeGuard; sub new { my ($class, $cb) = @_; bless { cb => $cb }, $class; } sub DESTROY { shift->{cb}->() } } { my $destroyed = 0; my $foo = do { my $bar = MyScopeGuard->new(sub { $destroyed++ }); my $foo = Foo->new({ bar => $bar }); my $clone = $foo->meta->clone_object($foo); is $destroyed, 0; $clone; }; isa_ok($foo, 'Foo'); is $foo->bar, undef; is $destroyed, 1; } { my $clone; { my $anon = Moose::Meta::Class->create_anon_class; my $foo = $anon->new_object; isa_ok($foo, $anon->name); ok(Class::MOP::class_of($foo), "has a metaclass"); $clone = $anon->clone_object($foo); isa_ok($clone, $anon->name); ok(Class::MOP::class_of($clone), "has a metaclass"); } ok(Class::MOP::class_of($clone), "still has a metaclass"); } { package Foo::Meta::Attr::Trait; use Moose::Role; has value_slot => ( is => 'ro', isa => 'Str', lazy => 1, default => sub { shift->name }, ); has count_slot => ( is => 'ro', isa => 'Str', lazy => 1, default => sub { '<>' . shift->name }, ); sub slots { my $self = shift; return ($self->value_slot, $self->count_slot); } sub _set_count { my $self = shift; my ($instance) = @_; my $mi = $self->associated_class->get_meta_instance; $mi->set_slot_value( $instance, $self->count_slot, ($mi->get_slot_value($instance, $self->count_slot) || 0) + 1, ); } sub _clear_count { my $self = shift; my ($instance) = @_; $self->associated_class->get_meta_instance->deinitialize_slot( $instance, $self->count_slot ); } sub has_count { my $self = shift; my ($instance) = @_; $self->associated_class->get_meta_instance->has_slot_value( $instance, $self->count_slot ); } sub count { my $self = shift; my ($instance) = @_; $self->associated_class->get_meta_instance->get_slot_value( $instance, $self->count_slot ); } after set_initial_value => sub { shift->_set_count(@_); }; after set_value => sub { shift->_set_count(@_); }; around _inline_instance_set => sub { my $orig = shift; my $self = shift; my ($instance) = @_; my $mi = $self->associated_class->get_meta_instance; return 'do { ' . $mi->inline_set_slot_value( $instance, $self->count_slot, $mi->inline_get_slot_value( $instance, $self->count_slot ) . ' + 1' ) . ';' . $self->$orig(@_) . '}'; }; after clear_value => sub { shift->_clear_count(@_); }; } { package Bar; use Moose; Moose::Util::MetaRole::apply_metaroles( for => __PACKAGE__, class_metaroles => { attribute => ['Foo::Meta::Attr::Trait'], }, ); has baz => ( is => 'rw' ); } { my $attr = Bar->meta->find_attribute_by_name('baz'); my $bar = Bar->new(baz => 1); is($attr->count($bar), 1, "right count"); $bar->baz(2); is($attr->count($bar), 2, "right count"); my $clone = $bar->meta->clone_object($bar); is($attr->count($clone), $attr->count($bar), "right count"); } done_testing; error_handling.t100644000767000024 115112200352344 17223 0ustar00etherstaff000000000000Moose-2.1005/t/basics#!/usr/bin/perl use strict; use warnings; use Test::More; use Test::Fatal; # This tests the error handling in Moose::Object only { package Foo; use Moose; } like( exception { Foo->new('bad') }, qr/^\QSingle parameters to new() must be a HASH ref/, 'A single non-hashref arg to a constructor throws an error' ); like( exception { Foo->new(undef) }, qr/^\QSingle parameters to new() must be a HASH ref/, 'A single non-hashref arg to a constructor throws an error' ); like( exception { Foo->does() }, qr/^\QYou must supply a role name to does()/, 'Cannot call does() without a role name' ); done_testing; load_into_main.t100644000767000024 42112200352344 17161 0ustar00etherstaff000000000000Moose-2.1005/t/basics#!/usr/bin/perl use strict; use warnings; use Test::More; use Test::Fatal; is( exception { eval 'use Moose'; }, undef, "export to main" ); isa_ok( main->meta, "Moose::Meta::Class" ); isa_ok( main->new, "main"); isa_ok( main->new, "Moose::Object" ); done_testing; delete_sub_stash.t100644000767000024 50112200352344 17215 0ustar00etherstaff000000000000Moose-2.1005/t/bugs#!/usr/bin/env perl use strict; use warnings; use Test::More; use Moose (); { package Foo; sub bar { 'BAR' } } my $method = \&Foo::bar; { no strict 'refs'; delete ${'::'}{'Foo::'}; } my $meta = Moose::Meta::Class->create('Bar'); $meta->add_method(bar => $method); is(Bar->bar, 'BAR'); done_testing; advanced_methods.t100644000767000024 1176012200352344 17237 0ustar00etherstaff000000000000Moose-2.1005/t/cmopuse strict; use warnings; use Test::More; use Test::Fatal; use Class::MOP; use Class::MOP::Class; =pod The following class hierarhcy is very contrived and totally horrid (it won't work under C3 even), but it tests a number of aspect of this module. A more real-world example would be a nice addition :) =cut { package Foo; sub BUILD { 'Foo::BUILD' } sub foo { 'Foo::foo' } package Bar; our @ISA = ('Foo'); sub BUILD { 'Bar::BUILD' } sub bar { 'Bar::bar' } package Baz; our @ISA = ('Bar'); sub baz { 'Baz::baz' } sub foo { 'Baz::foo' } package Foo::Bar; our @ISA = ('Foo', 'Bar'); sub BUILD { 'Foo::Bar::BUILD' } sub foobar { 'Foo::Bar::foobar' } package Foo::Bar::Baz; our @ISA = ('Foo', 'Bar', 'Baz'); sub BUILD { 'Foo::Bar::Baz::BUILD' } sub bar { 'Foo::Bar::Baz::bar' } sub foobarbaz { 'Foo::Bar::Baz::foobarbaz' } } ok(!defined(Class::MOP::Class->initialize('Foo')->find_next_method_by_name('BUILD')), '... Foo::BUILD has not next method'); is(Class::MOP::Class->initialize('Bar')->find_next_method_by_name('BUILD'), Class::MOP::Class->initialize('Foo')->get_method('BUILD'), '... Bar::BUILD does have a next method'); is(Class::MOP::Class->initialize('Baz')->find_next_method_by_name('BUILD'), Class::MOP::Class->initialize('Bar')->get_method('BUILD'), '... Baz->BUILD does have a next method'); is(Class::MOP::Class->initialize('Foo::Bar')->find_next_method_by_name('BUILD'), Class::MOP::Class->initialize('Foo')->get_method('BUILD'), '... Foo::Bar->BUILD does have a next method'); is(Class::MOP::Class->initialize('Foo::Bar::Baz')->find_next_method_by_name('BUILD'), Class::MOP::Class->initialize('Foo')->get_method('BUILD'), '... Foo::Bar::Baz->BUILD does have a next method'); is_deeply( [ sort { $a->name cmp $b->name } grep { $_->package_name ne 'UNIVERSAL' } Class::MOP::Class->initialize('Foo')->get_all_methods() ], [ Class::MOP::Class->initialize('Foo')->get_method('BUILD') , Class::MOP::Class->initialize('Foo')->get_method('foo'), ], '... got the right list of applicable methods for Foo'); is_deeply( [ sort { $a->name cmp $b->name } grep { $_->package_name ne 'UNIVERSAL' } Class::MOP::Class->initialize('Bar')->get_all_methods() ], [ Class::MOP::Class->initialize('Bar')->get_method('BUILD'), Class::MOP::Class->initialize('Bar')->get_method('bar'), Class::MOP::Class->initialize('Foo')->get_method('foo'), ], '... got the right list of applicable methods for Bar'); is_deeply( [ sort { $a->name cmp $b->name } grep { $_->package_name ne 'UNIVERSAL' } Class::MOP::Class->initialize('Baz')->get_all_methods() ], [ Class::MOP::Class->initialize('Bar')->get_method('BUILD'), Class::MOP::Class->initialize('Bar')->get_method('bar'), Class::MOP::Class->initialize('Baz')->get_method('baz'), Class::MOP::Class->initialize('Baz')->get_method('foo'), ], '... got the right list of applicable methods for Baz'); is_deeply( [ sort { $a->name cmp $b->name } grep { $_->package_name ne 'UNIVERSAL' } Class::MOP::Class->initialize('Foo::Bar')->get_all_methods() ], [ Class::MOP::Class->initialize('Foo::Bar')->get_method('BUILD'), Class::MOP::Class->initialize('Bar')->get_method('bar'), Class::MOP::Class->initialize('Foo')->get_method('foo'), Class::MOP::Class->initialize('Foo::Bar')->get_method('foobar'), ], '... got the right list of applicable methods for Foo::Bar'); ## find_all_methods_by_name is_deeply( [ Class::MOP::Class->initialize('Foo::Bar')->find_all_methods_by_name('BUILD') ], [ { name => 'BUILD', class => 'Foo::Bar', code => Class::MOP::Class->initialize('Foo::Bar')->get_method('BUILD') }, { name => 'BUILD', class => 'Foo', code => Class::MOP::Class->initialize('Foo')->get_method('BUILD') }, { name => 'BUILD', class => 'Bar', code => Class::MOP::Class->initialize('Bar')->get_method('BUILD') } ], '... got the right list of BUILD methods for Foo::Bar'); is_deeply( [ Class::MOP::Class->initialize('Foo::Bar::Baz')->find_all_methods_by_name('BUILD') ], [ { name => 'BUILD', class => 'Foo::Bar::Baz', code => Class::MOP::Class->initialize('Foo::Bar::Baz')->get_method('BUILD') }, { name => 'BUILD', class => 'Foo', code => Class::MOP::Class->initialize('Foo')->get_method('BUILD') }, { name => 'BUILD', class => 'Bar', code => Class::MOP::Class->initialize('Bar')->get_method('BUILD') }, ], '... got the right list of BUILD methods for Foo::Bar::Baz'); done_testing; method_modifiers.t100644000767000024 1274512200352344 17274 0ustar00etherstaff000000000000Moose-2.1005/t/cmopuse strict; use warnings; use Test::More; use Test::Fatal; use Class::MOP; use Class::MOP::Method; # test before and afters { my $trace = ''; my $method = Class::MOP::Method->wrap( body => sub { $trace .= 'primary' }, package_name => 'main', name => '__ANON__', ); isa_ok( $method, 'Class::MOP::Method' ); $method->(); is( $trace, 'primary', '... got the right return value from method' ); $trace = ''; my $wrapped = Class::MOP::Method::Wrapped->wrap($method); isa_ok( $wrapped, 'Class::MOP::Method::Wrapped' ); isa_ok( $wrapped, 'Class::MOP::Method' ); $wrapped->(); is( $trace, 'primary', '... got the right return value from the wrapped method' ); $trace = ''; is( exception { $wrapped->add_before_modifier( sub { $trace .= 'before -> ' } ); }, undef, '... added the before modifier okay' ); $wrapped->(); is( $trace, 'before -> primary', '... got the right return value from the wrapped method (w/ before)' ); $trace = ''; is( exception { $wrapped->add_after_modifier( sub { $trace .= ' -> after' } ); }, undef, '... added the after modifier okay' ); $wrapped->(); is( $trace, 'before -> primary -> after', '... got the right return value from the wrapped method (w/ before)' ); $trace = ''; } # test around method { my $method = Class::MOP::Method->wrap( sub {4}, package_name => 'main', name => '__ANON__', ); isa_ok( $method, 'Class::MOP::Method' ); is( $method->(), 4, '... got the right value from the wrapped method' ); my $wrapped = Class::MOP::Method::Wrapped->wrap($method); isa_ok( $wrapped, 'Class::MOP::Method::Wrapped' ); isa_ok( $wrapped, 'Class::MOP::Method' ); is( $wrapped->(), 4, '... got the right value from the wrapped method' ); is( exception { $wrapped->add_around_modifier( sub { ( 3, $_[0]->() ) } ); $wrapped->add_around_modifier( sub { ( 2, $_[0]->() ) } ); $wrapped->add_around_modifier( sub { ( 1, $_[0]->() ) } ); $wrapped->add_around_modifier( sub { ( 0, $_[0]->() ) } ); }, undef, '... added the around modifier okay' ); is_deeply( [ $wrapped->() ], [ 0, 1, 2, 3, 4 ], '... got the right results back from the around methods (in list context)' ); is( scalar $wrapped->(), 4, '... got the right results back from the around methods (in scalar context)' ); } { my @tracelog; my $method = Class::MOP::Method->wrap( sub { push @tracelog => 'primary' }, package_name => 'main', name => '__ANON__', ); isa_ok( $method, 'Class::MOP::Method' ); my $wrapped = Class::MOP::Method::Wrapped->wrap($method); isa_ok( $wrapped, 'Class::MOP::Method::Wrapped' ); isa_ok( $wrapped, 'Class::MOP::Method' ); is( exception { $wrapped->add_before_modifier( sub { push @tracelog => 'before 1' } ); $wrapped->add_before_modifier( sub { push @tracelog => 'before 2' } ); $wrapped->add_before_modifier( sub { push @tracelog => 'before 3' } ); }, undef, '... added the before modifier okay' ); is( exception { $wrapped->add_around_modifier( sub { push @tracelog => 'around 1'; $_[0]->(); } ); $wrapped->add_around_modifier( sub { push @tracelog => 'around 2'; $_[0]->(); } ); $wrapped->add_around_modifier( sub { push @tracelog => 'around 3'; $_[0]->(); } ); }, undef, '... added the around modifier okay' ); is( exception { $wrapped->add_after_modifier( sub { push @tracelog => 'after 1' } ); $wrapped->add_after_modifier( sub { push @tracelog => 'after 2' } ); $wrapped->add_after_modifier( sub { push @tracelog => 'after 3' } ); }, undef, '... added the after modifier okay' ); $wrapped->(); is_deeply( \@tracelog, [ 'before 3', 'before 2', 'before 1', # last-in-first-out order 'around 3', 'around 2', 'around 1', # last-in-first-out order 'primary', 'after 1', 'after 2', 'after 3', # first-in-first-out order ], '... got the right tracelog from all our before/around/after methods' ); } # test introspection { sub before1 { } sub before2 { } sub before3 { } sub after1 { } sub after2 { } sub after3 { } sub around1 { } sub around2 { } sub around3 { } sub orig { } my $method = Class::MOP::Method->wrap( body => \&orig, package_name => 'main', name => '__ANON__', ); my $wrapped = Class::MOP::Method::Wrapped->wrap($method); $wrapped->add_before_modifier($_) for \&before1, \&before2, \&before3; $wrapped->add_after_modifier($_) for \&after1, \&after2, \&after3; $wrapped->add_around_modifier($_) for \&around1, \&around2, \&around3; is( $wrapped->get_original_method, $method, 'check get_original_method' ); is_deeply( [ $wrapped->before_modifiers ], [ \&before3, \&before2, \&before1 ], 'check before_modifiers' ); is_deeply( [ $wrapped->after_modifiers ], [ \&after1, \&after2, \&after3 ], 'check after_modifiers' ); is_deeply( [ $wrapped->around_modifiers ], [ \&around3, \&around2, \&around1 ], 'check around_modifiers' ); } done_testing; numeric_defaults.t100644000767000024 644612200352344 17265 0ustar00etherstaff000000000000Moose-2.1005/t/cmop#!/usr/bin/env perl use strict; use warnings; use Test::More; use B; use Class::MOP; my @int_defaults = ( 100, -2, 01234, 0xFF, ); my @num_defaults = ( 10.5, -20.0, 1e3, 1.3e-10, ); my @string_defaults = ( 'foo', '', '100', '10.5', '1e3', '0 but true', '01234', '09876', '0xFF', ); for my $default (@int_defaults) { my $copy = $default; # so we can print it out without modifying flags my $attr = Class::MOP::Attribute->new( foo => (default => $default, reader => 'foo'), ); my $meta = Class::MOP::Class->create_anon_class( attributes => [$attr], methods => {bar => sub { $default }}, ); my $obj = $meta->new_object; for my $meth (qw(foo bar)) { my $val = $obj->$meth; my $b = B::svref_2object(\$val); my $flags = $b->FLAGS; ok($flags & B::SVf_IOK || $flags & B::SVp_IOK, "it's an int ($copy)"); ok(!($flags & B::SVf_POK), "not a string ($copy)"); } $meta->make_immutable; my $immutable_obj = $meta->name->new; for my $meth (qw(foo bar)) { my $val = $immutable_obj->$meth; my $b = B::svref_2object(\$val); my $flags = $b->FLAGS; ok($flags & B::SVf_IOK || $flags & B::SVp_IOK, "it's an int ($copy) (immutable)"); ok(!($flags & B::SVf_POK), "not a string ($copy) (immutable)"); } } for my $default (@num_defaults) { my $copy = $default; # so we can print it out without modifying flags my $attr = Class::MOP::Attribute->new( foo => (default => $default, reader => 'foo'), ); my $meta = Class::MOP::Class->create_anon_class( attributes => [$attr], methods => {bar => sub { $default }}, ); my $obj = $meta->new_object; for my $meth (qw(foo bar)) { my $val = $obj->$meth; my $b = B::svref_2object(\$val); my $flags = $b->FLAGS; ok($flags & B::SVf_NOK || $flags & B::SVp_NOK, "it's a num ($copy)"); ok(!($flags & B::SVf_POK), "not a string ($copy)"); } $meta->make_immutable; my $immutable_obj = $meta->name->new; for my $meth (qw(foo bar)) { my $val = $immutable_obj->$meth; my $b = B::svref_2object(\$val); my $flags = $b->FLAGS; ok($flags & B::SVf_NOK || $flags & B::SVp_NOK, "it's a num ($copy) (immutable)"); ok(!($flags & B::SVf_POK), "not a string ($copy) (immutable)"); } } for my $default (@string_defaults) { my $copy = $default; # so we can print it out without modifying flags my $attr = Class::MOP::Attribute->new( foo => (default => $default, reader => 'foo'), ); my $meta = Class::MOP::Class->create_anon_class( attributes => [$attr], methods => {bar => sub { $default }}, ); my $obj = $meta->new_object; for my $meth (qw(foo bar)) { my $val = $obj->$meth; my $b = B::svref_2object(\$val); my $flags = $b->FLAGS; ok($flags & B::SVf_POK, "it's a string ($copy)"); } $meta->make_immutable; my $immutable_obj = $meta->name->new; for my $meth (qw(foo bar)) { my $val = $immutable_obj->$meth; my $b = B::svref_2object(\$val); my $flags = $b->FLAGS; ok($flags & B::SVf_POK, "it's a string ($copy) (immutable)"); } } done_testing; rebless_instance.t100644000767000024 766512200352344 17263 0ustar00etherstaff000000000000Moose-2.1005/t/cmopuse strict; use warnings; use Test::More; use Test::Fatal; use Scalar::Util 'blessed'; { package Parent; use metaclass; sub new { bless {} => shift } sub whoami { "parent" } sub parent { "parent" } package Child; use metaclass; use base qw/Parent/; sub whoami { "child" } sub child { "child" } package LeftField; use metaclass; sub new { bless {} => shift } sub whoami { "leftfield" } sub myhax { "areleet" } } # basic tests my $foo = Parent->new; is(blessed($foo), 'Parent', 'Parent->new gives a Parent'); is($foo->whoami, "parent", 'Parent->whoami gives parent'); is($foo->parent, "parent", 'Parent->parent gives parent'); isnt( exception { $foo->child }, undef, "Parent->child method doesn't exist" ); Child->meta->rebless_instance($foo); is(blessed($foo), 'Child', 'rebless_instance really reblessed the instance'); is($foo->whoami, "child", 'reblessed->whoami gives child'); is($foo->parent, "parent", 'reblessed->parent gives parent'); is($foo->child, "child", 'reblessed->child gives child'); like( exception { LeftField->meta->rebless_instance($foo) }, qr/You may rebless only into a subclass of \(Child\), of which \(LeftField\) isn't\./ ); like( exception { Class::MOP::Class->initialize("NonExistent")->rebless_instance($foo) }, qr/You may rebless only into a subclass of \(Child\), of which \(NonExistent\) isn't\./ ); Parent->meta->rebless_instance_back($foo); is(blessed($foo), 'Parent', 'Parent->new gives a Parent'); is($foo->whoami, "parent", 'Parent->whoami gives parent'); is($foo->parent, "parent", 'Parent->parent gives parent'); isnt( exception { $foo->child }, undef, "Parent->child method doesn't exist" ); like( exception { LeftField->meta->rebless_instance_back($foo) }, qr/You may rebless only into a superclass of \(Parent\), of which \(LeftField\) isn't\./ ); like( exception { Class::MOP::Class->initialize("NonExistent")->rebless_instance_back($foo) }, qr/You may rebless only into a superclass of \(Parent\), of which \(NonExistent\) isn't\./ ); # make sure our ->meta is still sane my $bar = Parent->new; is(blessed($bar), 'Parent', "sanity check"); is(blessed($bar->meta), 'Class::MOP::Class', "meta gives a Class::MOP::Class"); is($bar->meta->name, 'Parent', "this Class::MOP::Class instance is for Parent"); ok($bar->meta->has_method('new'), 'metaclass has "new" method'); ok($bar->meta->has_method('whoami'), 'metaclass has "whoami" method'); ok($bar->meta->has_method('parent'), 'metaclass has "parent" method'); is(blessed($bar->meta->new_object), 'Parent', 'new_object gives a Parent'); Child->meta->rebless_instance($bar); is(blessed($bar), 'Child', "rebless really reblessed"); is(blessed($bar->meta), 'Class::MOP::Class', "meta gives a Class::MOP::Class"); is($bar->meta->name, 'Child', "this Class::MOP::Class instance is for Child"); ok($bar->meta->find_method_by_name('new'), 'metaclass has "new" method'); ok($bar->meta->find_method_by_name('parent'), 'metaclass has "parent" method'); ok(!$bar->meta->has_method('new'), 'no "new" method in this class'); ok(!$bar->meta->has_method('parent'), 'no "parent" method in this class'); ok($bar->meta->has_method('whoami'), 'metaclass has "whoami" method'); ok($bar->meta->has_method('child'), 'metaclass has "child" method'); is(blessed($bar->meta->new_object), 'Child', 'new_object gives a Child'); Parent->meta->rebless_instance_back($bar); is(blessed($bar), 'Parent', "sanity check"); is(blessed($bar->meta), 'Class::MOP::Class', "meta gives a Class::MOP::Class"); is($bar->meta->name, 'Parent', "this Class::MOP::Class instance is for Parent"); ok($bar->meta->has_method('new'), 'metaclass has "new" method'); ok($bar->meta->has_method('whoami'), 'metaclass has "whoami" method'); ok($bar->meta->has_method('parent'), 'metaclass has "parent" method'); is(blessed($bar->meta->new_object), 'Parent', 'new_object gives a Parent'); done_testing; rebless_overload.t100644000767000024 117612200352344 17261 0ustar00etherstaff000000000000Moose-2.1005/t/cmopuse strict; use warnings; use Test::More; use Class::MOP; do { package Without::Overloading; sub new { bless {}, shift } package With::Overloading; use base 'Without::Overloading'; use overload q{""} => sub { "overloaded" }; }; my $without = bless {}, "Without::Overloading"; like("$without", qr/^Without::Overloading/, "no overloading"); my $with = With::Overloading->new; is("$with", "overloaded", "initial overloading works"); my $meta = Class::MOP::Class->initialize('With::Overloading'); $meta->rebless_instance($without); is("$without", "overloaded", "overloading after reblessing works"); done_testing; MyMetaClass.pm100644000767000024 33212200352344 17001 0ustar00etherstaff000000000000Moose-2.1005/t/cmop/lib package MyMetaClass; use strict; use warnings; use base 'Class::MOP::Class'; sub mymetaclass_attributes{ my $self = shift; return grep { $_->isa("MyMetaClass::Attribute") } $self->get_all_attributes; } 1; SyntaxError.pm100644000767000024 16412200352344 17122 0ustar00etherstaff000000000000Moose-2.1005/t/cmop/lib#!/usr/bin/env perl package SyntaxError; use strict; use warnings; # this syntax error is intentional! { 1; Trait2.pm100600000767000024 24112200352344 16476 0ustar00etherstaff000000000000Moose-2.1005/t/lib/Bar7/Metapackage Bar7::Meta::Trait2; use Moose::Role; has foo => ( traits => ['Array'], handles => { push_foo => 'push', }, ); no Moose::Role; 1; meta_name.t100644000767000024 202712200352344 17217 0ustar00etherstaff000000000000Moose-2.1005/t/metaclasses#!/usr/bin/env perl use strict; use warnings; use Test::More; { # so we don't pick up stuff from Moose::Object package Base; sub foo { } # touch it so that 'extends' doesn't try to load it } { package Foo; use Moose; extends 'Base'; no Moose; } can_ok('Foo', 'meta'); is(Foo->meta, Class::MOP::class_of('Foo')); isa_ok(Foo->meta->get_method('meta'), 'Moose::Meta::Method::Meta'); { package Bar; use Moose -meta_name => 'bar_meta'; extends 'Base'; no Moose; } ok(!Bar->can('meta')); can_ok('Bar', 'bar_meta'); is(Bar->bar_meta, Class::MOP::class_of('Bar')); isa_ok(Bar->bar_meta->get_method('bar_meta'), 'Moose::Meta::Method::Meta'); { package Baz; use Moose -meta_name => undef; extends 'Base'; no Moose; } ok(!Baz->can('meta')); my $universal_method_count = scalar Class::MOP::class_of('UNIVERSAL')->get_all_methods; # 1 because of the dummy method we installed in Base is( ( scalar Class::MOP::class_of('Baz')->get_all_methods ) - $universal_method_count, 1 ); done_testing; moose_util000755000767000024 012200352344 14616 5ustar00etherstaff000000000000Moose-2.1005/tmoose_util.t100644000767000024 16112200352344 17300 0ustar00etherstaff000000000000Moose-2.1005/t/moose_util#!/usr/bin/perl use strict; use warnings; use Test::More; BEGIN { use_ok('Moose::Util'); } done_testing; anonymous_roles.t100644000767000024 325712200352344 17353 0ustar00etherstaff000000000000Moose-2.1005/t/roles#!/usr/bin/env perl use strict; use warnings; use Test::More; use Moose (); use Class::Load qw(is_class_loaded); my $role = Moose::Meta::Role->create_anon_role( attributes => { is_worn => { is => 'rw', isa => 'Bool', }, }, methods => { remove => sub { shift->is_worn(0) }, }, ); my $class = Moose::Meta::Class->create('MyItem::Armor::Helmet'); $role->apply($class); # XXX: Moose::Util::apply_all_roles doesn't cope with references yet my $visored = $class->new_object(is_worn => 0); ok(!$visored->is_worn, "attribute, accessor was consumed"); $visored->is_worn(1); ok($visored->is_worn, "accessor was consumed"); $visored->remove; ok(!$visored->is_worn, "method was consumed"); like($role->name, qr/^Moose::Meta::Role::__ANON__::SERIAL::\d+$/, ""); ok($role->is_anon_role, "the role knows it's anonymous"); ok(is_class_loaded(Moose::Meta::Role->create_anon_role->name), "creating an anonymous role satisifes is_class_loaded"); ok(Class::MOP::class_of(Moose::Meta::Role->create_anon_role->name), "creating an anonymous role satisifes class_of"); { my $role; { my $meta = Moose::Meta::Role->create_anon_role( methods => { foo => sub { 'FOO' }, }, ); $role = $meta->name; can_ok($role, 'foo'); } ok(!$role->can('foo')); } { my $role; { my $meta = Moose::Meta::Role->create_anon_role( methods => { foo => sub { 'FOO' }, }, ); $role = $meta->name; can_ok($role, 'foo'); Class::MOP::remove_metaclass_by_name($role); } ok(!$role->can('foo')); } done_testing; test_moose000755000767000024 012200352344 14620 5ustar00etherstaff000000000000Moose-2.1005/ttest_moose.t100644000767000024 16112200352344 17304 0ustar00etherstaff000000000000Moose-2.1005/t/test_moose#!/usr/bin/perl use strict; use warnings; use Test::More; BEGIN { use_ok('Test::Moose'); } done_testing; type_constraints000755000767000024 012200352344 16047 5ustar00etherstaff000000000000Moose-2.1005/tenum.t100644000767000024 623412200352344 17345 0ustar00etherstaff000000000000Moose-2.1005/t/type_constraints#!/usr/bin/perl use strict; use warnings; use Test::More; use Test::Fatal; use Scalar::Util (); use Moose::Util::TypeConstraints; enum Letter => 'a'..'z', 'A'..'Z'; enum Language => 'Perl 5', 'Perl 6', 'PASM', 'PIR'; # any others? ;) enum Metacharacter => ['*', '+', '?', '.', '|', '(', ')', '[', ']', '\\']; my @valid_letters = ('a'..'z', 'A'..'Z'); my @invalid_letters = qw/ab abc abcd/; push @invalid_letters, qw/0 4 9 ~ @ $ %/; push @invalid_letters, qw/l33t st3v4n 3num/; my @valid_languages = ('Perl 5', 'Perl 6', 'PASM', 'PIR'); my @invalid_languages = ('perl 5', 'Python', 'Ruby', 'Perl 666', 'PASM++'); # note that "perl 5" is invalid because case now matters my @valid_metacharacters = (qw/* + ? . | ( ) [ ] /, '\\'); my @invalid_metacharacters = qw/< > & % $ @ ! ~ `/; push @invalid_metacharacters, qw/.* fish(sticks)? atreides/; push @invalid_metacharacters, '^1?$|^(11+?)\1+$'; Moose::Util::TypeConstraints->export_type_constraints_as_functions(); ok(Letter($_), "'$_' is a letter") for @valid_letters; ok(!Letter($_), "'$_' is not a letter") for @invalid_letters; ok(Language($_), "'$_' is a language") for @valid_languages; ok(!Language($_), "'$_' is not a language") for @invalid_languages; ok(Metacharacter($_), "'$_' is a metacharacter") for @valid_metacharacters; ok(!Metacharacter($_), "'$_' is not a metacharacter") for @invalid_metacharacters; # check anon enums my $anon_enum = enum \@valid_languages; isa_ok($anon_enum, 'Moose::Meta::TypeConstraint'); is($anon_enum->name, '__ANON__', '... got the right name'); is($anon_enum->parent->name, 'Str', '... got the right parent name'); ok($anon_enum->check($_), "'$_' is a language") for @valid_languages; ok( !$anon_enum->equals( enum [qw(foo bar)] ), "doesn't equal a diff enum" ); ok( $anon_enum->equals( $anon_enum ), "equals itself" ); ok( $anon_enum->equals( enum \@valid_languages ), "equals duplicate" ); ok( !$anon_enum->is_subtype_of('Object'), 'enum not a subtype of Object'); ok( !$anon_enum->is_a_type_of('Object'), 'enum not type of Object'); ok( !$anon_enum->is_subtype_of('ThisTypeDoesNotExist'), 'enum not a subtype of nonexistant type'); ok( !$anon_enum->is_a_type_of('ThisTypeDoesNotExist'), 'enum not type of nonexistant type'); # validation like( exception { Moose::Meta::TypeConstraint::Enum->new(name => 'ZeroValues', values => []) }, qr/You must have at least one value to enumerate through/ ); is( exception { Moose::Meta::TypeConstraint::Enum->new(name => 'OneValue', values => [ 'a' ]) }, undef); like( exception { Moose::Meta::TypeConstraint::Enum->new(name => 'ReferenceInEnum', values => [ 'a', {} ]) }, qr/Enum values must be strings, not 'HASH\(0x\w+\)'/ ); like( exception { Moose::Meta::TypeConstraint::Enum->new(name => 'UndefInEnum', values => [ 'a', undef ]) }, qr/Enum values must be strings, not undef/ ); like( exception { package Foo; use Moose; use Moose::Util::TypeConstraints; has error => ( is => 'ro', isa => enum ['a', 'aa', 'aaa'], # should be parenthesized! default => 'aa', ); }, qr/enum called with an array reference and additional arguments\. Did you mean to parenthesize the enum call's parameters\?/ ); done_testing; pod-coverage.t100644000767000024 1606612200352344 17200 0ustar00etherstaff000000000000Moose-2.1005/xt/release#!/usr/bin/perl use strict; use warnings; use Test::More; use Test::Requires { 'Test::Pod::Coverage' => '1.04', # skip all if not installed }; # This is a stripped down version of all_pod_coverage_ok which lets us # vary the trustme parameter per module. my @modules = grep { !/Accessor::Native.*$/ && !/::Conflicts$/ } all_modules(); plan tests => scalar @modules; my %trustme = ( 'Class::MOP' => [ 'DEBUG_NO_META', 'HAVE_ISAREV', 'IS_RUNNING_ON_5_10', 'subname', 'in_global_destruction', 'check_package_cache_flag', 'load_first_existing_class', 'is_class_loaded', 'load_class', ], 'Class::MOP::Attribute' => ['process_accessors'], 'Class::MOP::Class' => [ # deprecated 'alias_method', 'compute_all_applicable_attributes', 'compute_all_applicable_methods', # unfinished feature 'add_dependent_meta_instance', 'add_meta_instance_dependencies', 'invalidate_meta_instance', 'invalidate_meta_instances', 'remove_dependent_meta_instance', 'remove_meta_instance_dependencies', 'update_meta_instance_dependencies', # effectively internal 'check_metaclass_compatibility', 'clone_instance', 'construct_class_instance', 'construct_instance', 'create_meta_instance', 'reset_package_cache_flag', 'update_package_cache_flag', 'reinitialize', # doc'd with rebless_instance 'rebless_instance_away', # deprecated 'get_attribute_map', ], 'Class::MOP::Class::Immutable::Trait' => ['.+'], 'Class::MOP::Class::Immutable::Class::MOP::Class' => ['.+'], 'Class::MOP::Deprecated' => ['.+'], 'Class::MOP::Instance' => [ qw( BUILDARGS bless_instance_structure is_dependent_on_superclasses ), ], 'Class::MOP::Instance' => [ qw( BUILDARGS bless_instance_structure is_dependent_on_superclasses ), ], 'Class::MOP::Method::Accessor' => [ qw( generate_accessor_method generate_accessor_method_inline generate_clearer_method generate_clearer_method_inline generate_predicate_method generate_predicate_method_inline generate_reader_method generate_reader_method_inline generate_writer_method generate_writer_method_inline initialize_body ) ], 'Class::MOP::Method::Constructor' => [ qw( attributes generate_constructor_method generate_constructor_method_inline initialize_body meta_instance options ) ], 'Class::MOP::Method::Generated' => [ qw( new definition_context is_inline initialize_body ) ], 'Class::MOP::MiniTrait' => ['.+'], 'Class::MOP::Mixin::AttributeCore' => ['.+'], 'Class::MOP::Mixin::HasAttributes' => ['.+'], 'Class::MOP::Mixin::HasMethods' => ['.+'], 'Class::MOP::Package' => [ 'get_method_map', 'wrap_method_body' ], 'Moose' => ['init_meta', 'throw_error'], 'Moose::Error::Confess' => ['new'], 'Moose::Error::Util' => ['.+'], 'Moose::Meta::Attribute' => [ qw( interpolate_class throw_error attach_to_class ) ], 'Moose::Meta::Attribute::Native::MethodProvider::Array' => ['.+'], 'Moose::Meta::Attribute::Native::MethodProvider::Bool' => ['.+'], 'Moose::Meta::Attribute::Native::MethodProvider::Code' => ['.+'], 'Moose::Meta::Attribute::Native::MethodProvider::Counter' => ['.+'], 'Moose::Meta::Attribute::Native::MethodProvider::Hash' => ['.+'], 'Moose::Meta::Attribute::Native::MethodProvider::String' => ['.+'], 'Moose::Meta::Class' => [ qw( check_metaclass_compatibility construct_instance create_error raise_error reinitialize superclasses ) ], 'Moose::Meta::Class::Immutable::Trait' => ['.+'], 'Moose::Meta::Method' => ['throw_error'], 'Moose::Meta::Method::Accessor' => [ qw( generate_accessor_method generate_accessor_method_inline generate_clearer_method generate_predicate_method generate_reader_method generate_reader_method_inline generate_writer_method generate_writer_method_inline new ) ], 'Moose::Meta::Method::Constructor' => [ qw( attributes initialize_body meta_instance new options ) ], 'Moose::Meta::Method::Destructor' => [ 'initialize_body', 'options' ], 'Moose::Meta::Method::Meta' => ['wrap'], 'Moose::Meta::Role' => [ qw( alias_method get_method_modifier_list reinitialize reset_package_cache_flag update_package_cache_flag wrap_method_body ) ], 'Moose::Meta::Mixin::AttributeCore' => ['.+'], 'Moose::Meta::Role::Composite' => [ 'get_method', 'get_method_list', 'has_method', 'add_method' ], 'Moose::Object' => ['BUILDALL', 'DEMOLISHALL'], 'Moose::Role' => [ qw( after around augment before extends has inner override super with init_meta ) ], 'Moose::Meta::TypeCoercion' => ['compile_type_coercion'], 'Moose::Meta::TypeCoercion::Union' => ['compile_type_coercion'], 'Moose::Meta::TypeConstraint' => [qw( compile_type_constraint inlined )], 'Moose::Meta::TypeConstraint::Class' => [qw( equals is_a_type_of is_a_subtype_of )], 'Moose::Meta::TypeConstraint::Enum' => [qw( constraint equals )], 'Moose::Meta::TypeConstraint::DuckType' => [qw( constraint equals get_message )], 'Moose::Meta::TypeConstraint::Parameterizable' => ['.+'], 'Moose::Meta::TypeConstraint::Parameterized' => ['.+'], 'Moose::Meta::TypeConstraint::Role' => [qw( equals is_a_type_of )], 'Moose::Meta::TypeConstraint::Union' => [ qw( compile_type_constraint coercion has_coercion can_be_inlined inline_environment ) ], 'Moose::Util' => ['add_method_modifier'], 'Moose::Util::MetaRole' => ['apply_metaclass_roles'], 'Moose::Util::TypeConstraints' => ['find_or_create_type_constraint'], 'Moose::Util::TypeConstraints::Builtins' => ['.+'], ); for my $module ( sort @modules ) { my $trustme = []; if ( $trustme{$module} ) { my $methods = join '|', @{ $trustme{$module} }; $trustme = [qr/^(?:$methods)$/]; } pod_coverage_ok( $module, { trustme => $trustme }, "Pod coverage for $module" ); } caf_vs_moose.pl100644000767000024 500112200352344 17445 0ustar00etherstaff000000000000Moose-2.1005/benchmarks#!perl ### MODULES { package PlainMoose; use Moose; has foo => (is => 'rw'); } { package MooseImmutable; use Moose; has foo => (is => 'rw'); __PACKAGE__->meta->make_immutable(); } { package MooseImmutable::NoConstructor; use Moose; has foo => (is => 'rw'); __PACKAGE__->meta->make_immutable(inline_constructor => 0); } { package ClassAccessorFast; use warnings; use strict; use base 'Class::Accessor::Fast'; __PACKAGE__->mk_accessors(qw(foo)); } use Benchmark qw(cmpthese); use Benchmark ':hireswallclock'; my $moose = PlainMoose->new; my $moose_immut = MooseImmutable->new; my $moose_immut_no_const = MooseImmutable::NoConstructor->new; my $caf = ClassAccessorFast->new; my $acc_rounds = 100_000; my $ins_rounds = 100_000; print "\nSETTING\n"; cmpthese($acc_rounds, { Moose => sub { $moose->foo(23) }, MooseImmutable => sub { $moose_immut->foo(23) }, MooseImmutableNoConstructor => sub { $moose_immut_no_const->foo(23) }, ClassAccessorFast => sub { $caf->foo(23) }, }, 'noc'); print "\nGETTING\n"; cmpthese($acc_rounds, { Moose => sub { $moose->foo }, MooseImmutable => sub { $moose_immut->foo }, MooseImmutableNoConstructor => sub { $moose_immut_no_const->foo }, ClassAccessorFast => sub { $caf->foo }, }, 'noc'); my (@moose, @moose_immut, @moose_immut_no_const, @caf_stall); print "\nCREATION\n"; cmpthese($ins_rounds, { Moose => sub { push @moose, PlainMoose->new(foo => 23) }, MooseImmutable => sub { push @moose_immut, MooseImmutable->new(foo => 23) }, MooseImmutableNoConstructor => sub { push @moose_immut_no_const, MooseImmutable::NoConstructor->new(foo => 23) }, ClassAccessorFast => sub { push @caf_stall, ClassAccessorFast->new({foo => 23}) }, }, 'noc'); my ( $moose_idx, $moose_immut_idx, $moose_immut_no_const_idx, $caf_idx ) = ( 0, 0, 0, 0 ); print "\nDESTRUCTION\n"; cmpthese($ins_rounds, { Moose => sub { $moose[$moose_idx] = undef; $moose_idx++; }, MooseImmutable => sub { $moose_immut[$moose_immut_idx] = undef; $moose_immut_idx++; }, MooseImmutableNoConstructor => sub { $moose_immut_no_const[$moose_immut_no_const_idx] = undef; $moose_immut_no_const_idx++; }, ClassAccessorFast => sub { $caf_stall[$caf_idx] = undef; $caf_idx++; }, }, 'noc'); simple_class.pl100600000767000024 102212200352344 17447 0ustar00etherstaff000000000000Moose-2.1005/benchmarks#!/usr/bin/perl use strict; use warnings; use Benchmark::Forking qw[cmpthese]; =pod This compares the burden of a basic Moose class to a basic Class::MOP class. It is worth noting that the basic Moose class will also create a type constraint as well as export many subs, so this comparison is really not fair :) =cut cmpthese(5_000, { 'w/out_moose' => sub { eval 'package Bar; use metaclass;'; }, 'w_moose' => sub { eval 'package Baz; use Moose;'; }, } ); 1;profile.pl100755000767000024 114312200352344 17406 0ustar00etherstaff000000000000Moose-2.1005/benchmarks/cmop#!perl -w # Usage: perl bench/profile.pl (no other options including -Mblib are reqired) use strict; my $script = 'bench/foo.pl'; my $branch = do { open my $in, '.git/HEAD' or die "Cannot open .git/HEAD: $!"; my $s = scalar <$in>; chomp $s; $s =~ s{^ref: \s+ refs/heads/}{}xms; $s =~ s{/}{_}xmsg; $s; }; print "Profiling $branch ...\n"; my @cmd = ( $^X, '-Iblib/lib', '-Iblib/arch', $script ); print "> @cmd\n"; system(@cmd) == 0 or die "Cannot profile"; @cmd = ( $^X, '-S', 'nytprofhtml', '--out', "nytprof-$branch" ); print "> @cmd\n"; system(@cmd) == 0 or die "Cannot profile"; run_yml.pl100644000767000024 47712200352344 17421 0ustar00etherstaff000000000000Moose-2.1005/benchmarks/cmop#!/usr/bin/perl use strict; use warnings; use FindBin; use lib "$FindBin::Bin/lib"; use YAML::Syck; use Bench::Run; my $data = LoadFile( shift || "$FindBin::Bin/all.yml" ); foreach my $bench ( @$data ) { print "== ", delete $bench->{name}, " ==\n\n"; Bench::Run->new( %$bench )->run; print "\n\n"; } Attribute.pm100644000767000024 7141612200352344 17134 0ustar00etherstaff000000000000Moose-2.1005/lib/Class/MOP package Class::MOP::Attribute; BEGIN { $Class::MOP::Attribute::AUTHORITY = 'cpan:STEVAN'; } { $Class::MOP::Attribute::VERSION = '2.1005'; } use strict; use warnings; use Class::MOP::Method::Accessor; use Carp 'confess'; use Scalar::Util 'blessed', 'weaken'; use Try::Tiny; use base 'Class::MOP::Object', 'Class::MOP::Mixin::AttributeCore'; # NOTE: (meta-circularity) # This method will be replaced in the # boostrap section of Class::MOP, by # a new version which uses the # &Class::MOP::Class::construct_instance # method to build an attribute meta-object # which itself is described with attribute # meta-objects. # - Ain't meta-circularity grand? :) sub new { my ( $class, @args ) = @_; unshift @args, "name" if @args % 2 == 1; my %options = @args; my $name = $options{name}; (defined $name) || confess "You must provide a name for the attribute"; $options{init_arg} = $name if not exists $options{init_arg}; if(exists $options{builder}){ confess("builder must be a defined scalar value which is a method name") if ref $options{builder} || !(defined $options{builder}); confess("Setting both default and builder is not allowed.") if exists $options{default}; } else { ($class->is_default_a_coderef(\%options)) || confess("References are not allowed as default values, you must ". "wrap the default of '$name' in a CODE reference (ex: sub { [] } and not [])") if exists $options{default} && ref $options{default}; } if( $options{required} and not( defined($options{builder}) || defined($options{init_arg}) || exists $options{default} ) ) { confess("A required attribute must have either 'init_arg', 'builder', or 'default'"); } $class->_new(\%options); } sub _new { my $class = shift; return Class::MOP::Class->initialize($class)->new_object(@_) if $class ne __PACKAGE__; my $options = @_ == 1 ? $_[0] : {@_}; bless { 'name' => $options->{name}, 'accessor' => $options->{accessor}, 'reader' => $options->{reader}, 'writer' => $options->{writer}, 'predicate' => $options->{predicate}, 'clearer' => $options->{clearer}, 'builder' => $options->{builder}, 'init_arg' => $options->{init_arg}, exists $options->{default} ? ('default' => $options->{default}) : (), 'initializer' => $options->{initializer}, 'definition_context' => $options->{definition_context}, # keep a weakened link to the # class we are associated with 'associated_class' => undef, # and a list of the methods # associated with this attr 'associated_methods' => [], # this let's us keep track of # our order inside the associated # class 'insertion_order' => undef, }, $class; } # NOTE: # this is a primitive (and kludgy) clone operation # for now, it will be replaced in the Class::MOP # bootstrap with a proper one, however we know # that this one will work fine for now. sub clone { my $self = shift; my %options = @_; (blessed($self)) || confess "Can only clone an instance"; return bless { %{$self}, %options } => ref($self); } sub initialize_instance_slot { my ($self, $meta_instance, $instance, $params) = @_; my $init_arg = $self->{'init_arg'}; # try to fetch the init arg from the %params ... # if nothing was in the %params, we can use the # attribute's default value (if it has one) if(defined $init_arg and exists $params->{$init_arg}){ $self->_set_initial_slot_value( $meta_instance, $instance, $params->{$init_arg}, ); } elsif (exists $self->{'default'}) { $self->_set_initial_slot_value( $meta_instance, $instance, $self->default($instance), ); } elsif (defined( my $builder = $self->{'builder'})) { if ($builder = $instance->can($builder)) { $self->_set_initial_slot_value( $meta_instance, $instance, $instance->$builder, ); } else { confess(ref($instance)." does not support builder method '". $self->{'builder'} ."' for attribute '" . $self->name . "'"); } } } sub _set_initial_slot_value { my ($self, $meta_instance, $instance, $value) = @_; my $slot_name = $self->name; return $meta_instance->set_slot_value($instance, $slot_name, $value) unless $self->has_initializer; my $callback = $self->_make_initializer_writer_callback( $meta_instance, $instance, $slot_name ); my $initializer = $self->initializer; # most things will just want to set a value, so make it first arg $instance->$initializer($value, $callback, $self); } sub _make_initializer_writer_callback { my $self = shift; my ($meta_instance, $instance, $slot_name) = @_; return sub { $meta_instance->set_slot_value($instance, $slot_name, $_[0]); }; } sub get_read_method { my $self = shift; my $reader = $self->reader || $self->accessor; # normal case ... return $reader unless ref $reader; # the HASH ref case my ($name) = %$reader; return $name; } sub get_write_method { my $self = shift; my $writer = $self->writer || $self->accessor; # normal case ... return $writer unless ref $writer; # the HASH ref case my ($name) = %$writer; return $name; } sub get_read_method_ref { my $self = shift; if ((my $reader = $self->get_read_method) && $self->associated_class) { return $self->associated_class->get_method($reader); } else { my $code = sub { $self->get_value(@_) }; if (my $class = $self->associated_class) { return $class->method_metaclass->wrap( $code, package_name => $class->name, name => '__ANON__' ); } else { return $code; } } } sub get_write_method_ref { my $self = shift; if ((my $writer = $self->get_write_method) && $self->associated_class) { return $self->associated_class->get_method($writer); } else { my $code = sub { $self->set_value(@_) }; if (my $class = $self->associated_class) { return $class->method_metaclass->wrap( $code, package_name => $class->name, name => '__ANON__' ); } else { return $code; } } } # slots sub slots { (shift)->name } # class association sub attach_to_class { my ($self, $class) = @_; (blessed($class) && $class->isa('Class::MOP::Class')) || confess "You must pass a Class::MOP::Class instance (or a subclass)"; weaken($self->{'associated_class'} = $class); } sub detach_from_class { my $self = shift; $self->{'associated_class'} = undef; } # method association sub associate_method { my ($self, $method) = @_; push @{$self->{'associated_methods'}} => $method; } ## Slot management sub set_initial_value { my ($self, $instance, $value) = @_; $self->_set_initial_slot_value( Class::MOP::Class->initialize(ref($instance))->get_meta_instance, $instance, $value ); } sub set_value { shift->set_raw_value(@_) } sub set_raw_value { my $self = shift; my ($instance, $value) = @_; my $mi = Class::MOP::Class->initialize(ref($instance))->get_meta_instance; return $mi->set_slot_value($instance, $self->name, $value); } sub _inline_set_value { my $self = shift; return $self->_inline_instance_set(@_) . ';'; } sub _inline_instance_set { my $self = shift; my ($instance, $value) = @_; my $mi = $self->associated_class->get_meta_instance; return $mi->inline_set_slot_value($instance, $self->name, $value); } sub get_value { shift->get_raw_value(@_) } sub get_raw_value { my $self = shift; my ($instance) = @_; my $mi = Class::MOP::Class->initialize(ref($instance))->get_meta_instance; return $mi->get_slot_value($instance, $self->name); } sub _inline_get_value { my $self = shift; return $self->_inline_instance_get(@_) . ';'; } sub _inline_instance_get { my $self = shift; my ($instance) = @_; my $mi = $self->associated_class->get_meta_instance; return $mi->inline_get_slot_value($instance, $self->name); } sub has_value { my $self = shift; my ($instance) = @_; my $mi = Class::MOP::Class->initialize(ref($instance))->get_meta_instance; return $mi->is_slot_initialized($instance, $self->name); } sub _inline_has_value { my $self = shift; return $self->_inline_instance_has(@_) . ';'; } sub _inline_instance_has { my $self = shift; my ($instance) = @_; my $mi = $self->associated_class->get_meta_instance; return $mi->inline_is_slot_initialized($instance, $self->name); } sub clear_value { my $self = shift; my ($instance) = @_; my $mi = Class::MOP::Class->initialize(ref($instance))->get_meta_instance; return $mi->deinitialize_slot($instance, $self->name); } sub _inline_clear_value { my $self = shift; return $self->_inline_instance_clear(@_) . ';'; } sub _inline_instance_clear { my $self = shift; my ($instance) = @_; my $mi = $self->associated_class->get_meta_instance; return $mi->inline_deinitialize_slot($instance, $self->name); } ## load em up ... sub accessor_metaclass { 'Class::MOP::Method::Accessor' } sub _process_accessors { my ($self, $type, $accessor, $generate_as_inline_methods) = @_; my $method_ctx = { %{ $self->definition_context || {} } }; if (ref($accessor)) { (ref($accessor) eq 'HASH') || confess "bad accessor/reader/writer/predicate/clearer format, must be a HASH ref"; my ($name, $method) = %{$accessor}; $method_ctx->{description} = $self->_accessor_description($name, $type); $method = $self->accessor_metaclass->wrap( $method, attribute => $self, package_name => $self->associated_class->name, name => $name, associated_metaclass => $self->associated_class, definition_context => $method_ctx, ); $self->associate_method($method); return ($name, $method); } else { my $inline_me = ($generate_as_inline_methods && $self->associated_class->instance_metaclass->is_inlinable); my $method; try { $method_ctx->{description} = $self->_accessor_description($accessor, $type); $method = $self->accessor_metaclass->new( attribute => $self, is_inline => $inline_me, accessor_type => $type, package_name => $self->associated_class->name, name => $accessor, associated_metaclass => $self->associated_class, definition_context => $method_ctx, ); } catch { confess "Could not create the '$type' method for " . $self->name . " because : $_"; }; $self->associate_method($method); return ($accessor, $method); } } sub _accessor_description { my $self = shift; my ($name, $type) = @_; my $desc = "$type " . $self->associated_class->name . "::$name"; if ( $name ne $self->name ) { $desc .= " of attribute " . $self->name; } return $desc; } sub install_accessors { my $self = shift; my $inline = shift; my $class = $self->associated_class; $class->add_method( $self->_process_accessors('accessor' => $self->accessor(), $inline) ) if $self->has_accessor(); $class->add_method( $self->_process_accessors('reader' => $self->reader(), $inline) ) if $self->has_reader(); $class->add_method( $self->_process_accessors('writer' => $self->writer(), $inline) ) if $self->has_writer(); $class->add_method( $self->_process_accessors('predicate' => $self->predicate(), $inline) ) if $self->has_predicate(); $class->add_method( $self->_process_accessors('clearer' => $self->clearer(), $inline) ) if $self->has_clearer(); return; } { my $_remove_accessor = sub { my ($accessor, $class) = @_; if (ref($accessor) && ref($accessor) eq 'HASH') { ($accessor) = keys %{$accessor}; } my $method = $class->get_method($accessor); $class->remove_method($accessor) if (ref($method) && $method->isa('Class::MOP::Method::Accessor')); }; sub remove_accessors { my $self = shift; # TODO: # we really need to make sure to remove from the # associates methods here as well. But this is # such a slimly used method, I am not worried # about it right now. $_remove_accessor->($self->accessor(), $self->associated_class()) if $self->has_accessor(); $_remove_accessor->($self->reader(), $self->associated_class()) if $self->has_reader(); $_remove_accessor->($self->writer(), $self->associated_class()) if $self->has_writer(); $_remove_accessor->($self->predicate(), $self->associated_class()) if $self->has_predicate(); $_remove_accessor->($self->clearer(), $self->associated_class()) if $self->has_clearer(); return; } } 1; # ABSTRACT: Attribute Meta Object __END__ =pod =head1 NAME Class::MOP::Attribute - Attribute Meta Object =head1 VERSION version 2.1005 =head1 SYNOPSIS Class::MOP::Attribute->new( foo => ( accessor => 'foo', # dual purpose get/set accessor predicate => 'has_foo', # predicate check for defined-ness init_arg => '-foo', # class->new will look for a -foo key default => 'BAR IS BAZ!' # if no -foo key is provided, use this ) ); Class::MOP::Attribute->new( bar => ( reader => 'bar', # getter writer => 'set_bar', # setter predicate => 'has_bar', # predicate check for defined-ness init_arg => ':bar', # class->new will look for a :bar key # no default value means it is undef ) ); =head1 DESCRIPTION The Attribute Protocol is almost entirely an invention of C. Perl 5 does not have a consistent notion of attributes. There are so many ways in which this is done, and very few (if any) are easily discoverable by this module. With that said, this module attempts to inject some order into this chaos, by introducing a consistent API which can be used to create object attributes. =head1 METHODS =head2 Creation =over 4 =item B<< Class::MOP::Attribute->new($name, ?%options) >> An attribute must (at the very least), have a C<$name>. All other C<%options> are added as key-value pairs. =over 8 =item * init_arg This is a string value representing the expected key in an initialization hash. For instance, if we have an C value of C<-foo>, then the following code will Just Work. MyClass->meta->new_object( -foo => 'Hello There' ); If an init_arg is not assigned, it will automatically use the attribute's name. If C is explicitly set to C, the attribute cannot be specified during initialization. =item * builder This provides the name of a method that will be called to initialize the attribute. This method will be called on the object after it is constructed. It is expected to return a valid value for the attribute. =item * default This can be used to provide an explicit default for initializing the attribute. If the default you provide is a subroutine reference, then this reference will be called I on the object. If the value is a simple scalar (string or number), then it can be just passed as is. However, if you wish to initialize it with a HASH or ARRAY ref, then you need to wrap that inside a subroutine reference: Class::MOP::Attribute->new( 'foo' => ( default => sub { [] }, ) ); # or ... Class::MOP::Attribute->new( 'foo' => ( default => sub { {} }, ) ); If you wish to initialize an attribute with a subroutine reference itself, then you need to wrap that in a subroutine as well: Class::MOP::Attribute->new( 'foo' => ( default => sub { sub { print "Hello World" } }, ) ); And lastly, if the value of your attribute is dependent upon some other aspect of the instance structure, then you can take advantage of the fact that when the C value is called as a method: Class::MOP::Attribute->new( 'object_identity' => ( default => sub { Scalar::Util::refaddr( $_[0] ) }, ) ); Note that there is no guarantee that attributes are initialized in any particular order, so you cannot rely on the value of some other attribute when generating the default. =item * initializer This option can be either a method name or a subroutine reference. This method will be called when setting the attribute's value in the constructor. Unlike C and C, the initializer is only called when a value is provided to the constructor. The initializer allows you to munge this value during object construction. The initializer is called as a method with three arguments. The first is the value that was passed to the constructor. The second is a subroutine reference that can be called to actually set the attribute's value, and the last is the associated C object. This contrived example shows an initializer that sets the attribute to twice the given value. Class::MOP::Attribute->new( 'doubled' => ( initializer => sub { my ( $self, $value, $set, $attr ) = @_; $set->( $value * 2 ); }, ) ); Since an initializer can be a method name, you can easily make attribute initialization use the writer: Class::MOP::Attribute->new( 'some_attr' => ( writer => 'some_attr', initializer => 'some_attr', ) ); Your writer (actually, a wrapper around the writer, using L) will need to examine C<@_> and determine under which context it is being called: around 'some_attr' => sub { my $orig = shift; my $self = shift; # $value is not defined if being called as a reader # $setter and $attr are only defined if being called as an initializer my ($value, $setter, $attr) = @_; # the reader behaves normally return $self->$orig if not @_; # mutate $value as desired # $value = ($row) if $setter; # otherwise, call the real writer with the new value $self->$orig($row); }; =back The C, C, C, C and C options all accept the same parameters. You can provide the name of the method, in which case an appropriate default method will be generated for you. Or instead you can also provide hash reference containing exactly one key (the method name) and one value. The value should be a subroutine reference, which will be installed as the method itself. =over 8 =item * accessor An C is a standard Perl-style read/write accessor. It will return the value of the attribute, and if a value is passed as an argument, it will assign that value to the attribute. Note that C is a legitimate value, so this will work: $object->set_something(undef); =item * reader This is a basic read-only accessor. It returns the value of the attribute. =item * writer This is a basic write accessor, it accepts a single argument, and assigns that value to the attribute. Note that C is a legitimate value, so this will work: $object->set_something(undef); =item * predicate The predicate method returns a boolean indicating whether or not the attribute has been explicitly set. Note that the predicate returns true even if the attribute was set to a false value (C<0> or C). =item * clearer This method will uninitialize the attribute. After an attribute is cleared, its C will return false. =item * definition_context Mostly, this exists as a hook for the benefit of Moose. This option should be a hash reference containing several keys which will be used when inlining the attribute's accessors. The keys should include C, the line number where the attribute was created, and either C or C. This information will ultimately be used when eval'ing inlined accessor code so that error messages report a useful line and file name. =back =item B<< $attr->clone(%options) >> This clones the attribute. Any options you provide will override the settings of the original attribute. You can change the name of the new attribute by passing a C key in C<%options>. =back =head2 Informational These are all basic read-only accessors for the values passed into the constructor. =over 4 =item B<< $attr->name >> Returns the attribute's name. =item B<< $attr->accessor >> =item B<< $attr->reader >> =item B<< $attr->writer >> =item B<< $attr->predicate >> =item B<< $attr->clearer >> The C, C, C, C, and C methods all return exactly what was passed to the constructor, so it can be either a string containing a method name, or a hash reference. =item B<< $attr->initializer >> Returns the initializer as passed to the constructor, so this may be either a method name or a subroutine reference. =item B<< $attr->init_arg >> =item B<< $attr->is_default_a_coderef >> =item B<< $attr->builder >> =item B<< $attr->default($instance) >> The C<$instance> argument is optional. If you don't pass it, the return value for this method is exactly what was passed to the constructor, either a simple scalar or a subroutine reference. If you I pass an C<$instance> and the default is a subroutine reference, then the reference is called as a method on the C<$instance> and the generated value is returned. =item B<< $attr->slots >> Return a list of slots required by the attribute. This is usually just one, the name of the attribute. A slot is the name of the hash key used to store the attribute in an object instance. =item B<< $attr->get_read_method >> =item B<< $attr->get_write_method >> Returns the name of a method suitable for reading or writing the value of the attribute in the associated class. If an attribute is read- or write-only, then these methods can return C as appropriate. =item B<< $attr->has_read_method >> =item B<< $attr->has_write_method >> This returns a boolean indicating whether the attribute has a I read or write method. =item B<< $attr->get_read_method_ref >> =item B<< $attr->get_write_method_ref >> Returns the subroutine reference of a method suitable for reading or writing the attribute's value in the associated class. These methods always return a subroutine reference, regardless of whether or not the attribute is read- or write-only. =item B<< $attr->insertion_order >> If this attribute has been inserted into a class, this returns a zero based index regarding the order of insertion. =back =head2 Informational predicates These are all basic predicate methods for the values passed into C. =over 4 =item B<< $attr->has_accessor >> =item B<< $attr->has_reader >> =item B<< $attr->has_writer >> =item B<< $attr->has_predicate >> =item B<< $attr->has_clearer >> =item B<< $attr->has_initializer >> =item B<< $attr->has_init_arg >> This will be I if the C was set to C. =item B<< $attr->has_default >> This will be I if the C was set to C, since C is the default C anyway. =item B<< $attr->has_builder >> =item B<< $attr->has_insertion_order >> This will be I if this attribute has not be inserted into a class =back =head2 Value management These methods are basically "back doors" to the instance, and can be used to bypass the regular accessors, but still stay within the MOP. These methods are not for general use, and should only be used if you really know what you are doing. =over 4 =item B<< $attr->initialize_instance_slot($meta_instance, $instance, $params) >> This method is used internally to initialize the attribute's slot in the object C<$instance>. The C<$params> is a hash reference of the values passed to the object constructor. It's unlikely that you'll need to call this method yourself. =item B<< $attr->set_value($instance, $value) >> Sets the value without going through the accessor. Note that this works even with read-only attributes. =item B<< $attr->set_raw_value($instance, $value) >> Sets the value with no side effects such as a trigger. This doesn't actually apply to Class::MOP attributes, only to subclasses. =item B<< $attr->set_initial_value($instance, $value) >> Sets the value without going through the accessor. This method is only called when the instance is first being initialized. =item B<< $attr->get_value($instance) >> Returns the value without going through the accessor. Note that this works even with write-only accessors. =item B<< $attr->get_raw_value($instance) >> Returns the value without any side effects such as lazy attributes. Doesn't actually apply to Class::MOP attributes, only to subclasses. =item B<< $attr->has_value($instance) >> Return a boolean indicating whether the attribute has been set in C<$instance>. This how the default C method works. =item B<< $attr->clear_value($instance) >> This will clear the attribute's value in C<$instance>. This is what the default C calls. Note that this works even if the attribute does not have any associated read, write or clear methods. =back =head2 Class association These methods allow you to manage the attributes association with the class that contains it. These methods should not be used lightly, nor are they very magical, they are mostly used internally and by metaclass instances. =over 4 =item B<< $attr->associated_class >> This returns the C with which this attribute is associated, if any. =item B<< $attr->attach_to_class($metaclass) >> This method stores a weakened reference to the C<$metaclass> object internally. This method does not remove the attribute from its old class, nor does it create any accessors in the new class. It is probably best to use the L C method instead. =item B<< $attr->detach_from_class >> This method removes the associate metaclass object from the attribute it has one. This method does not remove the attribute itself from the class, or remove its accessors. It is probably best to use the L C method instead. =back =head2 Attribute Accessor generation =over 4 =item B<< $attr->accessor_metaclass >> Accessor methods are generated using an accessor metaclass. By default, this is L. This method returns the name of the accessor metaclass that this attribute uses. =item B<< $attr->associate_method($method) >> This associates a L object with the attribute. Typically, this is called internally when an attribute generates its accessors. =item B<< $attr->associated_methods >> This returns the list of methods which have been associated with the attribute. =item B<< $attr->install_accessors >> This method generates and installs code the attributes various accessors. It is typically called from the L C method. =item B<< $attr->remove_accessors >> This method removes all of the accessors associated with the attribute. This does not currently remove methods from the list returned by C. =item B<< $attr->inline_get >> =item B<< $attr->inline_set >> =item B<< $attr->inline_has >> =item B<< $attr->inline_clear >> These methods return a code snippet suitable for inlining the relevant operation. They expect strings containing variable names to be used in the inlining, like C<'$self'> or C<'$_[1]'>. =back =head2 Introspection =over 4 =item B<< Class::MOP::Attribute->meta >> This will return a L instance for this class. It should also be noted that L will actually bootstrap this module by installing a number of attribute meta-objects into its metaclass. =back =head1 AUTHOR Moose is maintained by the Moose Cabal, along with the help of many contributors. See L and L for details. =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2013 by Infinity Interactive, Inc.. This is free software; you can redistribute it and/or modify it under the same terms as the Perl 5 programming language system itself. =cut MiniTrait.pm100644000767000024 340712200352344 17044 0ustar00etherstaff000000000000Moose-2.1005/lib/Class/MOPpackage Class::MOP::MiniTrait; BEGIN { $Class::MOP::MiniTrait::AUTHORITY = 'cpan:STEVAN'; } { $Class::MOP::MiniTrait::VERSION = '2.1005'; } use strict; use warnings; use Class::Load qw(load_class); sub apply { my ( $to_class, $trait ) = @_; for ( grep { !ref } $to_class, $trait ) { load_class($_); $_ = Class::MOP::Class->initialize($_); } for my $meth ( grep { $_->package_name ne 'UNIVERSAL' } $trait->get_all_methods ) { my $meth_name = $meth->name; if ( $to_class->find_method_by_name($meth_name) ) { $to_class->add_around_method_modifier( $meth_name, $meth->body ); } else { $to_class->add_method( $meth_name, $meth->clone ); } } } # We can't load this with use, since it may be loaded and used from Class::MOP # (via CMOP::Class, etc). However, if for some reason this module is loaded # _without_ first loading Class::MOP we need to require Class::MOP so we can # use it and CMOP::Class. require Class::MOP; 1; # ABSTRACT: Extremely limited trait application __END__ =pod =head1 NAME Class::MOP::MiniTrait - Extremely limited trait application =head1 VERSION version 2.1005 =head1 DESCRIPTION This package provides a single function, C, which does a half-assed job of applying a trait to a class. It exists solely for use inside Class::MOP and L core classes. =head1 AUTHOR Moose is maintained by the Moose Cabal, along with the help of many contributors. See L and L for details. =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2013 by Infinity Interactive, Inc.. This is free software; you can redistribute it and/or modify it under the same terms as the Perl 5 programming language system itself. =cut Confess.pm100644000767000024 256612200352344 17224 0ustar00etherstaff000000000000Moose-2.1005/lib/Moose/Errorpackage Moose::Error::Confess; BEGIN { $Moose::Error::Confess::AUTHORITY = 'cpan:STEVAN'; } { $Moose::Error::Confess::VERSION = '2.1005'; } use strict; use warnings; use base qw(Moose::Error::Default); sub new { my ( $self, @args ) = @_; $self->create_error_confess(@args); } sub _inline_new { my ( $self, %args ) = @_; my $depth = ($args{depth} || 0) - 1; return 'Moose::Error::Util::create_error_confess(' . 'message => ' . $args{message} . ', ' . 'depth => ' . $depth . ', ' . ')'; } 1; # ABSTRACT: Prefer C __END__ =pod =head1 NAME Moose::Error::Confess - Prefer C =head1 VERSION version 2.1005 =head1 SYNOPSIS # Metaclass definition must come before Moose is used. use metaclass ( metaclass => 'Moose::Meta::Class', error_class => 'Moose::Error::Confess', ); use Moose; # ... =head1 DESCRIPTION This error class uses L to raise errors generated in your metaclass. =head1 AUTHOR Moose is maintained by the Moose Cabal, along with the help of many contributors. See L and L for details. =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2013 by Infinity Interactive, Inc.. This is free software; you can redistribute it and/or modify it under the same terms as the Perl 5 programming language system itself. =cut Default.pm100644000767000024 477112200352344 17210 0ustar00etherstaff000000000000Moose-2.1005/lib/Moose/Errorpackage Moose::Error::Default; BEGIN { $Moose::Error::Default::AUTHORITY = 'cpan:STEVAN'; } { $Moose::Error::Default::VERSION = '2.1005'; } use strict; use warnings; use Carp::Heavy; use Class::MOP::MiniTrait; use Moose::Error::Util; use base 'Class::MOP::Object'; Class::MOP::MiniTrait::apply(__PACKAGE__, 'Moose::Meta::Object::Trait'); sub new { my ( $self, @args ) = @_; # can't use Moose::Error::Util::create_error here because that would break # inheritance. we don't care about that for the inlined version, because # the inlined versions are explicitly not inherited. if (defined $ENV{MOOSE_ERROR_STYLE} && $ENV{MOOSE_ERROR_STYLE} eq 'croak') { $self->create_error_croak( @args ); } else { $self->create_error_confess( @args ); } } sub _inline_new { my ( $self, %args ) = @_; my $depth = ($args{depth} || 0) - 1; return 'Moose::Error::Util::create_error(' . 'message => ' . $args{message} . ', ' . 'depth => ' . $depth . ', ' . ')'; } sub create_error_croak { my ( $self, @args ) = @_; return Moose::Error::Util::create_error_croak(@args); } sub create_error_confess { my ( $self, @args ) = @_; return Moose::Error::Util::create_error_confess(@args); } 1; # ABSTRACT: L based error generation for Moose. __END__ =pod =head1 NAME Moose::Error::Default - L based error generation for Moose. =head1 VERSION version 2.1005 =head1 DESCRIPTION This class implements L based error generation. The default behavior is like L. To override this to default to L's behaviour on a system wide basis, set the MOOSE_ERROR_STYLE environment variable to C. The use of this environment variable is considered experimental, and may change in a future release. =head1 METHODS =over 4 =item B<< Moose::Error::Default->new(@args) >> Create a new error. Delegates to C or C. =item B<< $error->create_error_confess(@args) >> =item B<< $error->create_error_croak(@args) >> Creates a new errors string of the specified style. =back =head1 AUTHOR Moose is maintained by the Moose Cabal, along with the help of many contributors. See L and L for details. =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2013 by Infinity Interactive, Inc.. This is free software; you can redistribute it and/or modify it under the same terms as the Perl 5 programming language system itself. =cut Delta.pod100644000767000024 11256012200352344 17203 0ustar00etherstaff000000000000Moose-2.1005/lib/Moose/Manualpackage Moose::Manual::Delta; # ABSTRACT: Important Changes in Moose __END__ =pod =head1 NAME Moose::Manual::Delta - Important Changes in Moose =head1 VERSION version 2.1005 =head1 DESCRIPTION This documents any important or noteworthy changes in Moose, with a focus on things that affect backwards compatibility. This does duplicate data from the F file, but aims to provide more details and when possible workarounds. Besides helping keep up with changes, you can also use this document for finding the lowest version of Moose that supported a given feature. If you encounter a problem and have a solution but don't see it documented here, or think we missed an important feature, please send us a patch. =head1 2.1000 =over 4 =item The Num type is now stricter The C type used to accept anything that fits Perl's notion of a number, which included Inf, NaN, and strings like C<" 1234 \n">. We believe that the type constraint should indicate "this is a number", not "this coerces to a number". Therefore, now Num accepts only integers, floating point numbers (both in decimal notation and exponential notation), 0, .0, 0.0 etc. If you want the old behavior you can use the C type in L. =item You can use L instead of core Moose types The L distribution is an experimental new type system intended to eventually replace the core Moose types, but yet also work with things like L and L and anything else. Right now this is all speculative, but at least you can use Specio with Moose. =back =head1 2.0600 =over 4 =item C<< ->init_meta >> is even less reliable at loading extensions Previously, calling C<< MooseX::Foo->init_meta(@_) >> (and nothing else) from within your own C had a decent chance of doing something useful. This was never supported behavior, and didn't always work anyway. Due to some implementation adjustments, this now has a smaller chance of doing something useful, which could break code that was expecting it to continue doing useful things. Code that does this should instead just call C<< MooseX::Foo->import({ into => $into }) >>. =item All the Cookbook recipes have been renamed We've given them all descriptive names, rather than numbers. This makes it easier to talk about them, and eliminates the need to renumber recipes in order to reorder them or delete one. =back =head1 2.0400 =over 4 =item The parent of a union type is its components' nearest common ancestor Previously, union types considered all of their component types their parent types. This was incorrect because parent types are defined as types that must be satisfied in order for the child type to be satisfied, but in a union, validating as any parent type will validate against the entire union. This has been changed to find the nearest common ancestor for all of its components. For example, a union of "Int|ArrayRef[Int]" now has a parent of "Defined". =item Union types consider all members in the C and C methods Previously, a union type would report itself as being of a subtype of a type if I of its member types were subtypes of that type. This was incorrect because any value that passes a subtype constraint must also pass a parent constraint. This has changed so that I of its member types must be a subtype of the specified type. =item Enum types now work with just one value Previously, an C type needed to have two or more values. Nobody knew why, so we fixed it. =item Methods defined in UNIVERSAL now appear in the MOP Any method introspection methods that look at methods from parent classes now find methods defined in UNIVERSAL. This includes methods like C<< $class->get_all_methods >> and C<< $class->find_method_by_name >>. This also means that you can now apply method modifiers to these methods. =item Hand-optimized type constraint code causes a deprecation warning If you provide an optimized sub ref for a type constraint, this now causes a deprecation warning. Typically, this comes from passing an C parameter to C, but it could also happen if you create a L object directly. Use the inlining feature (C) added in 2.0100 instead. =item C and C have been removed The C and C subroutines are no longer documented, and will cause a deprecation warning in the future. Moose now uses L to provide this functionality, and you should do so as well. =back =head1 2.0205 =over 4 =item Array and Hash native traits provide a C method The Array and Hash native traits now provide a "shallow_clone" method, which will return a reference to a new container with the same contents as the attribute's reference. =back =head1 2.0200 =over 4 =item Hand-optimized type constraint code is deprecated in favor of inlining Moose allows you to provide a hand-optimized version of a type constraint's subroutine reference. This version allows type constraints to generate inline code, and you should use this inlining instead of providing a hand-optimized subroutine reference. This affects the C sub exported by L. Use C instead. This will start warning in the 2.0300 release. =back =head1 2.0002 =over 4 =item More useful type constraint error messages If you have L version 0.14 or higher installed, Moose's type constraint error messages will use it to display the invalid value, rather than just displaying it directly. This will generally be much more useful. For instance, instead of this: Attribute (foo) does not pass the type constraint because: Validation failed for 'ArrayRef[Int]' with value ARRAY(0x275eed8) the error message will instead look like Attribute (foo) does not pass the type constraint because: Validation failed for 'ArrayRef[Int]' with value [ "a" ] Note that L can't be made a direct dependency at the moment, because it uses Moose itself, but we're considering options to make this easier. =back =head1 2.0000 =over 4 =item Roles have their own default attribute metaclass Previously, when a role was applied to a class, it would use the attribute metaclass defined in the class when copying over the attributes in the role. This was wrong, because for instance, using L in the class would end up renaming all of the accessors generated by the role, some of which may be being called in the role, causing it to break. Roles now keep track of their own attribute metaclass to use by default when being applied to a class (defaulting to Moose::Meta::Attribute). This is modifiable using L by passing the C key to the C option, as in: Moose::Util::MetaRole::apply_metaroles( for => __PACKAGE__, class_metaroles => { attribute => ['My::Meta::Role::Attribute'], }, role_metaroles => { applied_attribute => ['My::Meta::Role::Attribute'], }, ); =item Class::MOP has been folded into the Moose dist Moose and Class::MOP are tightly related enough that they have always had to be kept pretty closely in step in terms of versions. Making them into a single dist should simplify the upgrade process for users, as it should no longer be possible to upgrade one without the other and potentially cause issues. No functionality has changed, and this should be entirely transparent. =item Moose's conflict checking is more robust and useful There are two parts to this. The most useful one right now is that Moose will ship with a C script, which can be run at any point to list the modules which are installed that conflict with the installed version of Moose. After upgrading Moose, running C should be sufficient to ensure that all of the Moose extensions you use will continue to work. The other part is that Moose's C file will also specify the conflicts under the C key. We are working with the Perl tool chain developers to try to get conflicts support added to CPAN clients, and if/when that happens, the metadata already exists, and so the conflict checking will become automatic. =item Most deprecated APIs/features are slated for removal in Moose 2.0200 Most of the deprecated APIs and features in Moose will start throwing an error in Moose 2.0200. Some of the features will go away entirely, and some will simply throw an error. The things on the chopping block are: =over 8 =item * Old public methods in Class::MOP and Moose This includes things like C<< Class::MOP::Class->get_attribute_map >>, C<< Class::MOP::Class->construct_instance >>, and many others. These were deprecated in L 0.80_01, released on April 5, 2009. These methods will be removed entirely in Moose 2.0200. =item * Old public functions in Class::MOP This include C, C, and the C constant. The first two were deprecated in 0.84, and the last in 0.80. Class::MOP 0.84 was released on May 12, 2009. These functions will be removed entirely in Moose 2.0200. =item * The C and C option for role composition These were renamed to C<-alias> and C<-excludes> in Moose 0.89, released on August 13, 2009. Passing these will throw an error in Moose 2.0200. =item * The old L API This include the C function, as well as passing the C or any key ending in C<_roles> to C. This was deprecated in Moose 0.93_01, released on January 4, 2010. These will all throw an error in Moose 2.0200. =item * Passing plain lists to C or C The old API for these functions allowed you to pass a plain list of parameter, rather than a list of hash references (which is what C, C, etc. return). This was deprecated in Moose 0.71_01, released on February 22, 2009. This will throw an error in Moose 2.0200. =item * The Role subtype This subtype was deprecated in Moose 0.84, released on June 26, 2009. This will be removed entirely in Moose 2.0200. =back =back =head1 1.21 =over 4 =item * New release policy As of the 2.0 release, Moose now has an official release and support policy, documented in L. All API changes will now go through a deprecation cycle of at least one year, after which the deprecated API can be removed. Deprecations and removals will only happen in major releases. In between major releases, we will still make minor releases to add new features, fix bugs, update documentation, etc. =back =head1 1.16 =over 4 =item Configurable stacktraces Classes which use the L error class can now have stacktraces disabled by setting the C env var to C. This is experimental, fairly incomplete, and won't work in all cases (because Moose's error system in general is all of these things), but this should allow for reducing at least some of the verbosity in most cases. =back =head1 1.15 =over 4 =item Native Delegations In previous versions of Moose, the Native delegations were created as closures. The generated code was often quite slow compared to doing the same thing by hand. For example, the Array's push delegation ended up doing something like this: push @{ $self->$reader() }, @_; If the attribute was created without a reader, the C<$reader> sub reference followed a very slow code path. Even with a reader, this is still slower than it needs to be. Native delegations are now generated as inline code, just like other accessors, so we can access the slot directly. In addition, native traits now do proper constraint checking in all cases. In particular, constraint checking has been improved for array and hash references. Previously, only the I type (the C in C) would be checked when a new value was added to the collection. However, if there was a constraint that applied to the whole value, this was never checked. In addition, coercions are now called on the whole value. The delegation methods now do more argument checking. All of the methods check that a valid number of arguments were passed to the method. In addition, the delegation methods check that the arguments are sane (array indexes, hash keys, numbers, etc.) when applicable. We have tried to emulate the behavior of Perl builtins as much as possible. Finally, triggers are called whenever the value of the attribute is changed by a Native delegation. These changes are only likely to break code in a few cases. The inlining code may or may not preserve the original reference when changes are made. In some cases, methods which change the value may replace it entirely. This will break tied values. If you have a typed arrayref or hashref attribute where the type enforces a constraint on the whole collection, this constraint will now be checked. It's possible that code which previously ran without errors will now cause the constraint to fail. However, presumably this is a good thing ;) If you are passing invalid arguments to a delegation which were previously being ignored, these calls will now fail. If your code relied on the trigger only being called for a regular writer, that may cause problems. As always, you are encouraged to test before deploying the latest version of Moose to production. =item Defaults is and default for String, Counter, and Bool A few native traits (String, Counter, Bool) provide default values of "is" and "default" when you created an attribute. Allowing them to provide these values is now deprecated. Supply the value yourself when creating the attribute. =item The C method Moose and Class::MOP have been cleaned up internally enough to make the C method that you get by default optional. C and C now can take an additional C<-meta_name> option, which tells Moose what name to use when installing the C method. Passing C to this option suppresses generation of the C method entirely. This should be useful for users of modules which also use a C method or function, such as L or L. =back =head1 1.09 =over 4 =item All deprecated features now warn Previously, deprecation mostly consisted of simply saying "X is deprecated" in the Changes file. We were not very consistent about actually warning. Now, all deprecated features still present in Moose actually give a warning. The warning is issued once per calling package. See L for more details. =item You cannot pass C<< coerce => 1 >> unless the attribute's type constraint has a coercion Previously, this was accepted, and it sort of worked, except that if you attempted to set the attribute after the object was created, you would get a runtime error. Now you will get a warning when you attempt to define the attribute. =item C, C, and C no longer unimport strict and warnings This change was made in 1.05, and has now been reverted. We don't know if the user has explicitly loaded strict or warnings on their own, and unimporting them is just broken in that case. =item Reversed logic when defining which options can be changed L now allows all options to be changed in an overridden attribute. The previous behaviour required each option to be whitelisted using the C method. This method has been removed, and there is a new method, C, which can now be used to prevent certain options from being changeable. In addition, we only throw an error if the illegal option is actually changed. If the superclass didn't specify this option at all when defining the attribute, the subclass version can still add it as an option. Example of overriding this in an attribute trait: package Bar::Meta::Attribute; use Moose::Role; has 'my_illegal_option' => ( isa => 'CodeRef', is => 'rw', ); around illegal_options_for_inheritance => sub { return ( shift->(@_), qw/my_illegal_option/ ); }; =back =head1 1.05 =over 4 =item L methods are now called when calling C Previously, C methods would only be called from C, but now they are also called when constructing an object via C. C methods are an inherent part of the object construction process, and this should make C<< $meta->new_object >> actually usable without forcing people to use C<< $meta->name->new >>. =item C, C, and C now unimport strict and warnings In the interest of having C clean up everything that C does in the calling scope, C (as well as all other L-using modules) now unimports strict and warnings. =item Metaclass compatibility checking and fixing should be much more robust The L checking and fixing algorithms have been completely rewritten, in both Class::MOP and Moose. This should resolve many confusing errors when dealing with non-Moose inheritance and with custom metaclasses for things like attributes, constructors, etc. For correct code, the only thing that should require a change is that custom error metaclasses must now inherit from L. =back =head1 1.02 =over 4 =item Moose::Meta::TypeConstraint::Class is_subtype_of behavior Earlier versions of L would incorrectly return true when called with itself, its own TC name or its class name as an argument. (i.e. $foo_tc->is_subtype_of('Foo') == 1) This behavior was a caused by C being checked before the class name. The old behavior can be accessed with L =back =head1 1.00 =over 4 =item Moose::Meta::Attribute::Native::Trait::Code no longer creates reader methods by default Earlier versions of L created read-only accessors for the attributes it's been applied to, even if you didn't ask for it with C<< is => 'ro' >>. This incorrect behaviour has now been fixed. =back =head1 0.95 =over 4 =item Moose::Util add_method_modifier behavior add_method_modifier (and subsequently the sugar functions Moose::before, Moose::after, and Moose::around) can now accept arrayrefs, with the same behavior as lists. Types other than arrayref and regexp result in an error. =back =head1 0.93_01 and 0.94 =over 4 =item Moose::Util::MetaRole API has changed The C function is now called C. The way arguments are supplied has been changed to force you to distinguish between metaroles applied to L (and helpers) versus L. The old API still works, but will warn in a future release, and eventually be removed. =item Moose::Meta::Role has real attributes The attributes returned by L are now instances of the L class, instead of bare hash references. =item "no Moose" now removes C and C Moose is now smart enough to know exactly what it exported, even when it re-exports functions from other packages. When you unimport Moose, it will remove these functions from your namespace unless you I imported them directly from their respective packages. If you have a C in your code I you call C or C, your code will break. You can either move the C call later in your code, or explicitly import the relevant functions from the packages that provide them. =item L is smarter about unimporting re-exports The change above comes from a general improvement to L. It will now unimport any function it exports, even if that function is a re-export from another package. =item Attributes in roles can no longer override class attributes with "+foo" Previously, this worked more or less accidentally, because role attributes weren't objects. This was never documented, but a few MooseX modules took advantage of this. =item The composition_class_roles attribute in L is now a method This was done to make it possible for roles to alter the list of composition class roles by applying a method modifiers. Previously, this was an attribute and MooseX modules override it. Since that no longer works, this was made a method. This I be an attribute, so this may switch back to being an attribute in the future if we can figure out how to make this work. =back =head1 0.93 =over 4 =item Calling $object->new() is no longer deprecated We decided to undeprecate this. Now it just works. =item Both C and C is deprecated These metaclass methods were never meant to be public, and they are both now deprecated. The work around if you still need the functionality they provided is to iterate over the list of names manually. my %fields = map { $_ => $meta->get_attribute($_) } $meta->get_attribute_list; This was actually a change in L, but this version of Moose requires a version of L that includes said change. =back =head1 0.90 =over 4 =item Added Native delegation for Code refs See L for details. =item Calling $object->new() is deprecated Moose has long supported this, but it's never really been documented, and we don't think this is a good practice. If you want to construct an object from an existing object, you should provide some sort of alternate constructor like C<< $object->clone >>. Calling C<< $object->new >> now issues a warning, and will be an error in a future release. =item Moose no longer warns if you call C for a class with mutable ancestors While in theory this is a good thing to warn about, we found so many exceptions to this that doing this properly became quite problematic. =back =head1 0.89_02 =over 4 =item New Native delegation methods from L and L In particular, we now have C, C, C, and C. =item The Moose::Exporter with_caller feature is now deprecated Use C instead. The C option will start warning in a future release. =item Moose now warns if you call C for a class with mutable ancestors This is dangerous because modifying a class after a subclass has been immutabilized will lead to incorrect results in the subclass, due to inlining, caching, etc. This occasionally happens accidentally, when a class loads one of its subclasses in the middle of its class definition, so pointing out that this may cause issues should be helpful. Metaclasses (classes that inherit from L) are currently exempt from this check, since at the moment we aren't very consistent about which metaclasses we immutabilize. =item C and C now take arrayrefs for all forms Previously, calling these functions with a list would take the first element of the list as the type constraint name, and use the remainder as the enum values or method names. This makes the interface inconsistent with the anon-type forms of these functions (which must take an arrayref), and a free-form list where the first value is sometimes special is hard to validate (and harder to give reasonable error messages for). These functions have been changed to take arrayrefs in all their forms - so, C<< enum 'My::Type' => [qw(foo bar)] >> is now the preferred way to create an enum type constraint. The old syntax still works for now, but it will hopefully be deprecated and removed in a future release. =back =head1 0.89_01 L has been moved into the Moose core from L. Major changes include: =over 4 =item C, not C Method providers are only available via traits. =item C, not C or C The C syntax was like core Moose C<< handles => HASHREF >> syntax, but with the keys and values reversed. This was confusing, and AttributeHelpers now uses C<< handles => HASHREF >> in a way that should be intuitive to anyone already familiar with how it is used for other attributes. The C functionality provided by AttributeHelpers has been generalized to apply to all cases of C<< handles => HASHREF >>, though not every piece of functionality has been ported (currying with a CODEREF is not supported). =item C is now C, and means empty, not non-empty Previously, the C method provided by Arrays and Hashes returned true if the attribute was B empty (no elements). Now it returns true if the attribute B empty. It was also renamed to C, to reflect this. =item C was renamed to C, and C and C were removed L refers to the functionality that we used to provide under C as L, so that will likely be more familiar (and will fit in better if we decide to add more List::Util functions). C and C were removed, since their functionality is easily duplicated with curries of C. =item Helpers that take a coderef of one argument now use C<$_> Subroutines passed as the first argument to C, C, and C now receive their argument in C<$_> rather than as a parameter to the subroutine. Helpers that take a coderef of two or more arguments remain using the argument list (there are technical limitations to using C<$a> and C<$b> like C does). See L for the new documentation. =back The C and C role parameters have been renamed to C<-alias> and C<-excludes>. The old names still work, but new code should use the new names, and eventually the old ones will be deprecated and removed. =head1 0.89 C<< use Moose -metaclass => 'Foo' >> now does alias resolution, just like C<-traits> (and the C and C options to C). Added two functions C and C to L, to simplify aliasing metaclasses and metatraits. This is a wrapper around the old package Moose::Meta::Class::Custom::Trait::FooTrait; sub register_implementation { 'My::Meta::Trait' } way of doing this. =head1 0.84 When an attribute generates I accessors, we now warn. This is to help users who forget the C option. If you really do not want any accessors, you can use C<< is => 'bare' >>. You can maintain back compat with older versions of Moose by using something like: ($Moose::VERSION >= 0.84 ? is => 'bare' : ()) When an accessor overwrites an existing method, we now warn. To work around this warning (if you really must have this behavior), you can explicitly remove the method before creating it as an accessor: sub foo {} __PACKAGE__->meta->remove_method('foo'); has foo => ( is => 'ro', ); When an unknown option is passed to C, we now warn. You can silence the warning by fixing your code. :) The C type has been deprecated. On its own, it was useless, since it just checked C<< $object->can('does') >>. If you were using it as a parent type, just call C to create an appropriate type instead. =head1 0.78 C now imports C and C into packages that use it. =head1 0.77 C and C now receive an argument indicating whether or not we are in global destruction. =head1 0.76 Type constraints no longer run coercions for a value that already matches the constraint. This may affect some (arguably buggy) edge case coercions that rely on side effects in the C clause. =head1 0.75 L now accepts the C<-metaclass> option for easily overriding the metaclass (without L). This works for classes and roles. =head1 0.74 Added a C sugar function to L to make integration with non-Moose classes easier. It simply checks if C<< $obj->can() >> a list of methods. A number of methods (mostly inherited from L) have been renamed with a leading underscore to indicate their internal-ness. The old method names will still work for a while, but will warn that the method has been renamed. In a few cases, the method will be removed entirely in the future. This may affect MooseX authors who were using these methods. =head1 0.73 Calling C with a name as the only argument now throws an exception. If you want an anonymous subtype do: my $subtype = subtype as 'Foo'; This is related to the changes in version 0.71_01. The C method in L is now only usable as a class method. Previously, it worked as a class or object method, with a different internal implementation for each version. The internals of making a class immutable changed a lot in Class::MOP 0.78_02, and Moose's internals have changed along with it. The external C<< $metaclass->make_immutable >> method still works the same way. =head1 0.72 A mutable class accepted C<< Foo->new(undef) >> without complaint, while an immutable class would blow up with an unhelpful error. Now, in both cases we throw a helpful error instead. This "feature" was originally added to allow for cases such as this: my $args; if ( something() ) { $args = {...}; } return My::Class->new($args); But we decided this is a bad idea and a little too magical, because it can easily mask real errors. =head1 0.71_01 Calling C or C without the sugar helpers (C, C, C) is now deprecated. As a side effect, this meant we ended up using Perl prototypes on C, and code like this will no longer work: use Moose::Util::TypeConstraints; use Declare::Constraints::Simple -All; subtype 'ArrayOfInts' => as 'ArrayRef' => IsArrayRef(IsInt); Instead it must be changed to this: subtype( 'ArrayOfInts' => { as => 'ArrayRef', where => IsArrayRef(IsInt) } ); If you want to maintain backwards compat with older versions of Moose, you must explicitly test Moose's C: if ( Moose->VERSION < 0.71_01 ) { subtype 'ArrayOfInts' => as 'ArrayRef' => IsArrayRef(IsInt); } else { subtype( 'ArrayOfInts' => { as => 'ArrayRef', where => IsArrayRef(IsInt) } ); } =head1 0.70 We no longer pass the meta-attribute object as a final argument to triggers. This actually changed for inlined code a while back, but the non-inlined version and the docs were still out of date. If by some chance you actually used this feature, the workaround is simple. You fetch the attribute object from out of the C<$self> that is passed as the first argument to trigger, like so: has 'foo' => ( is => 'ro', isa => 'Any', trigger => sub { my ( $self, $value ) = @_; my $attr = $self->meta->find_attribute_by_name('foo'); # ... } ); =head1 0.66 If you created a subtype and passed a parent that Moose didn't know about, it simply ignored the parent. Now it automatically creates the parent as a class type. This may not be what you want, but is less broken than before. You could declare a name with subtype such as "Foo!Bar". Moose would accept this allowed, but if you used it in a parameterized type such as "ArrayRef[Foo!Bar]" it wouldn't work. We now do some vetting on names created via the sugar functions, so that they can only contain alphanumerics, ":", and ".". =head1 0.65 Methods created via an attribute can now fulfill a C declaration for a role. Honestly we don't know why Stevan didn't make this work originally, he was just insane or something. Stack traces from inlined code will now report the line and file as being in your class, as opposed to in Moose guts. =head1 0.62_02 When a class does not provide all of a role's required methods, the error thrown now mentions all of the missing methods, as opposed to just the first missing method. Moose will no longer inline a constructor for your class unless it inherits its constructor from Moose::Object, and will warn when it doesn't inline. If you want to force inlining anyway, pass C<< replace_constructor => 1 >> to C. If you want to get rid of the warning, pass C<< inline_constructor => 0 >>. =head1 0.62 Removed the (deprecated) C keyword. Removing an attribute from a class now also removes delegation (C) methods installed for that attribute. This is correct behavior, but if you were wrongly relying on it you might get bit. =head1 0.58 Roles now add methods by calling C, not C. They make sure to always provide a method object, which will be cloned internally. This means that it is now possible to track the source of a method provided by a role, and even follow its history through intermediate roles. This means that methods added by a role now show up when looking at a class's method list/map. Parameter and Union args are now sorted, this makes Int|Str the same constraint as Str|Int. Also, incoming type constraint strings are normalized to remove all whitespace differences. This is mostly for internals and should not affect outside code. L will no longer remove a subroutine that the exporting package re-exports. Moose re-exports the Carp::confess function, among others. The reasoning is that we cannot know whether you have also explicitly imported those functions for your own use, so we err on the safe side and always keep them. =head1 0.56 C should now be called as a method. New modules for extension writers, L and L. =head1 0.55_01 Implemented metaclass traits (and wrote a recipe for it): use Moose -traits => 'Foo' This should make writing small Moose extensions a little easier. =head1 0.55 Fixed C to accept anon types just like C can. So that you can do: coerce $some_anon_type => from 'Str' => via { ... }; =head1 0.51 Added C, a new step in C<< Moose::Object->new() >>. =head1 0.49 Fixed how the C<< is => (ro|rw) >> works with custom defined C, C and C options. See the below table for details: is => ro, writer => _foo # turns into (reader => foo, writer => _foo) is => rw, writer => _foo # turns into (reader => foo, writer => _foo) is => rw, accessor => _foo # turns into (accessor => _foo) is => ro, accessor => _foo # error, accesor is rw =head1 0.45 The C method modifiers now support regexp matching of method names. NOTE: this only works for classes, it is currently not supported in roles, but, ... patches welcome. The C keyword for roles now accepts the same array ref form that L.pm does for classes. A trigger on a read-only attribute is no longer an error, as it's useful to trigger off of the constructor. Subtypes of parameterizable types now are parameterizable types themselves. =head1 0.44 Fixed issue where C was eating the value in C<$@>, and so not working correctly. It still kind of eats them, but so does vanilla perl. =head1 0.41 Inherited attributes may now be extended without restriction on the type ('isa', 'does'). The entire set of Moose::Meta::TypeConstraint::* classes were refactored in this release. If you were relying on their internals you should test your code carefully. =head1 0.40 Documenting the use of '+name' with attributes that come from recently composed roles. It makes sense, people are using it, and so why not just officially support it. The C<< Moose::Meta::Class->create >> method now supports roles. It is now possible to make anonymous enum types by passing C an array reference instead of the C<< enum $name => @values >>. =head1 0.37 Added the C keyword as a shortcut to calling C on the meta object. This eventually got removed! Made C<< init_arg => undef >> work in Moose. This means "do not accept a constructor parameter for this attribute". Type errors now use the provided message. Prior to this release they didn't. =head1 0.34 Moose is now a postmodern object system :) The Role system was completely refactored. It is 100% backwards compat, but the internals were totally changed. If you relied on the internals then you are advised to test carefully. Added method exclusion and aliasing for Roles in this release. Added the L module. Passing a list of values to an accessor (which is only expecting one value) used to be silently ignored, now it throws an error. =head1 0.26 Added parameterized types and did a pretty heavy refactoring of the type constraint system. Better framework extensibility and better support for "making your own Moose". =head1 0.25 or before Honestly, you shouldn't be using versions of Moose that are this old, so many bug fixes and speed improvements have been made you would be crazy to not upgrade. Also, I am tired of going through the Changelog so I am stopping here, if anyone would like to continue this please feel free. =head1 AUTHOR Moose is maintained by the Moose Cabal, along with the help of many contributors. See L and L for details. =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2013 by Infinity Interactive, Inc.. This is free software; you can redistribute it and/or modify it under the same terms as the Perl 5 programming language system itself. =cut Roles.pod100644000767000024 2215312200352344 17214 0ustar00etherstaff000000000000Moose-2.1005/lib/Moose/Manualpackage Moose::Manual::Roles; # ABSTRACT: Roles, an alternative to deep hierarchies and base classes __END__ =pod =head1 NAME Moose::Manual::Roles - Roles, an alternative to deep hierarchies and base classes =head1 VERSION version 2.1005 =head1 WHAT IS A ROLE? A role encapsulates some piece of behavior or state that can be shared between classes. It is something that classes I. It is important to understand that I. You cannot inherit from a role, and a role cannot be instantiated. We sometimes say that roles are I, either by classes or other roles. Instead, a role is I into a class. In practical terms, this means that all of the methods, method modifiers, and attributes defined in a role are added directly to (we sometimes say "flattened into") the class that consumes the role. These attributes and methods then appear as if they were defined in the class itself. A subclass of the consuming class will inherit all of these methods and attributes. Moose roles are similar to mixins or interfaces in other languages. Besides defining their own methods and attributes, roles can also require that the consuming class define certain methods of its own. You could have a role that consisted only of a list of required methods, in which case the role would be very much like a Java interface. Note that attribute accessors also count as methods for the purposes of satisfying the requirements of a role. =head1 A SIMPLE ROLE Creating a role looks a lot like creating a Moose class: package Breakable; use Moose::Role; has 'is_broken' => ( is => 'rw', isa => 'Bool', ); sub break { my $self = shift; print "I broke\n"; $self->is_broken(1); } Except for our use of L, this looks just like a class definition with Moose. However, this is not a class, and it cannot be instantiated. Instead, its attributes and methods will be composed into classes which use the role: package Car; use Moose; with 'Breakable'; has 'engine' => ( is => 'ro', isa => 'Engine', ); The C function composes roles into a class. Once that is done, the C class has an C attribute and a C method. The C class also C: my $car = Car->new( engine => Engine->new ); print $car->is_broken ? 'Busted' : 'Still working'; $car->break; print $car->is_broken ? 'Busted' : 'Still working'; $car->does('Breakable'); # true This prints: Still working I broke Busted We could use this same role in a C class: package Bone; use Moose; with 'Breakable'; has 'marrow' => ( is => 'ro', isa => 'Marrow', ); See also L for an example. =head1 REQUIRED METHODS As mentioned previously, a role can require that consuming classes provide one or more methods. Using our C example, let's make it require that consuming classes implement their own C methods: package Breakable; use Moose::Role; requires 'break'; has 'is_broken' => ( is => 'rw', isa => 'Bool', ); after 'break' => sub { my $self = shift; $self->is_broken(1); }; If we try to consume this role in a class that does not have a C method, we will get an exception. You can see that we added a method modifier on C. We want classes that consume this role to implement their own logic for breaking, but we make sure that the C attribute is always set to true when C is called. package Car use Moose; with 'Breakable'; has 'engine' => ( is => 'ro', isa => 'Engine', ); sub break { my $self = shift; if ( $self->is_moving ) { $self->stop; } } =head2 Roles Versus Abstract Base Classes If you are familiar with the concept of abstract base classes in other languages, you may be tempted to use roles in the same way. You I define an "interface-only" role, one that contains I a list of required methods. However, any class which consumes this role must implement all of the required methods, either directly or through inheritance from a parent. You cannot delay the method requirement check so that they can be implemented by future subclasses. Because the role defines the required methods directly, adding a base class to the mix would not achieve anything. We recommend that you simply consume the interface role in each class which implements that interface. =head2 Required Attributes As mentioned before, a role's required method may also be satisfied by an attribute accessor. However, the call to C which defines an attribute happens at runtime. This means that you must define the attribute I consuming the role, or else the role will not see the generated accessor. package Breakable; use Moose::Role; requires 'stress'; package Car; use Moose; has 'stress' => ( is => 'rw', isa => 'Int', ); with 'Breakable'; =head1 USING METHOD MODIFIERS Method modifiers and roles are a very powerful combination. Often, a role will combine method modifiers and required methods. We already saw one example with our C example. Method modifiers increase the complexity of roles, because they make the role application order relevant. If a class uses multiple roles, each of which modify the same method, those modifiers will be applied in the same order as the roles are used: package MovieCar; use Moose; extends 'Car'; with 'Breakable', 'ExplodesOnBreakage'; Assuming that the new C role I has an C modifier on C, the C modifiers will run one after the other. The modifier from C will run first, then the one from C. =head1 METHOD CONFLICTS If a class composes multiple roles, and those roles have methods of the same name, we will have a conflict. In that case, the composing class is required to provide its I method of the same name. package Breakdancer; use Moose::Role; sub break { } If we compose both C and C in a class, we must provide our own C method: package FragileDancer; use Moose; with 'Breakable', 'Breakdancer'; sub break { ... } A role can be a collection of other roles: package Break::Bundle; use Moose::Role; with ('Breakable', 'Breakdancer'); =head1 METHOD EXCLUSION AND ALIASING If we want our C class to be able to call the methods from both its roles, we can alias the methods: package FragileDancer; use Moose; with 'Breakable' => { -alias => { break => 'break_bone' } }, 'Breakdancer' => { -alias => { break => 'break_dance' } }; However, aliasing a method simply makes a I of the method with the new name. We also need to exclude the original name: with 'Breakable' => { -alias => { break => 'break_bone' }, -excludes => 'break', }, 'Breakdancer' => { -alias => { break => 'break_dance' }, -excludes => 'break', }; The excludes parameter prevents the C method from being composed into the C class, so we don't have a conflict. This means that C does not need to implement its own C method. This is useful, but it's worth noting that this breaks the contract implicit in consuming a role. Our C class does both the C and C, but does not provide a C method. If some API expects an object that does one of those roles, it probably expects it to implement that method. In some use cases we might alias and exclude methods from roles, but then provide a method of the same name in the class itself. Also see L for an example. =head1 ROLE EXCLUSION A role can say that it cannot be combined with some other role. This should be used with great caution, since it limits the re-usability of the role. package Breakable; use Moose::Role; excludes 'BreakDancer'; =head1 ADDING A ROLE TO AN OBJECT INSTANCE You may want to add a role to an object instance, rather than to a class. For example, you may want to add debug tracing to one instance of an object while debugging a particular bug. Another use case might be to dynamically change objects based on a user's configuration, as a plugin system. The best way to do this is to use the C function from L: use Moose::Util qw( apply_all_roles ); my $car = Car->new; apply_all_roles( $car, 'Breakable' ); This function can apply more than one role at a time, and will do so using the normal Moose role combination system. We recommend using this function to apply roles to an object. This is what Moose uses internally when you call C. =head1 AUTHOR Moose is maintained by the Moose Cabal, along with the help of many contributors. See L and L for details. =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2013 by Infinity Interactive, Inc.. This is free software; you can redistribute it and/or modify it under the same terms as the Perl 5 programming language system itself. =cut Types.pod100644000767000024 3152312200352344 17235 0ustar00etherstaff000000000000Moose-2.1005/lib/Moose/Manualpackage Moose::Manual::Types; # ABSTRACT: Moose's type system __END__ =pod =head1 NAME Moose::Manual::Types - Moose's type system =head1 VERSION version 2.1005 =head1 TYPES IN PERL? Moose provides its own type system for attributes. You can also use these types to validate method parameters with the help of a MooseX module. Moose's type system is based on a combination of Perl 5's own I types and some Perl 6 concepts. You can create your own subtypes with custom constraints, making it easy to express any sort of validation. Types have names, and you can re-use them by name, making it easy to share types throughout a large application. However, this is not a "real" type system. Moose does not magically make Perl start associating types with variables. This is just an advanced parameter checking system which allows you to associate a name with a constraint. That said, it's still pretty damn useful, and we think it's one of the things that makes Moose both fun and powerful. Taking advantage of the type system makes it much easier to ensure that you are getting valid data, and it also contributes greatly to code maintainability. =head1 THE TYPES The basic Moose type hierarchy looks like this Any Item Bool Maybe[`a] Undef Defined Value Str Num Int ClassName RoleName Ref ScalarRef[`a] ArrayRef[`a] HashRef[`a] CodeRef RegexpRef GlobRef FileHandle Object In practice, the only difference between C and C is conceptual. C is used as the top-level type in the hierarchy. The rest of these types correspond to existing Perl concepts. In particular: =over 4 =item C accepts C<1> for true, and undef, 0, or the empty string as false. =item C accepts either C<`a> or C. =item C accepts integers, floating point numbers (both in decimal notation & exponential notation), 0, .0, 0.0 etc. It doesn't accept numbers with whitespace, Inf, Infinity, "0 but true", NaN & other such strings. =item C and C accept strings that are either the name of a class or the name of a role. The class/role must already be loaded when the constraint is checked. =item C accepts either an L object or a builtin perl filehandle (see L). =item C accepts any blessed reference. =back The types followed by "[`a]" can be parameterized. So instead of just plain C we can say that we want C instead. We can even do something like C. The C type deserves a special mention. Used by itself, it doesn't really mean anything (and is equivalent to C). When it is parameterized, it means that the value is either C or the parameterized type. So C means an integer or C. For more details on the type hierarchy, see L. =head1 WHAT IS A TYPE? It's important to realize that types are not classes (or packages). Types are just objects (L objects, to be exact) with a name and a constraint. Moose maintains a global type registry that lets it convert names like C into the appropriate object. However, class names I type names. When you define a new class using Moose, it defines an associated type name behind the scenes: package MyApp::User; use Moose; Now you can use C<'MyApp::User'> as a type name: has creator => ( is => 'ro', isa => 'MyApp::User', ); However, for non-Moose classes there's no magic. You may have to explicitly declare the class type. This is a bit muddled because Moose assumes that any unknown type name passed as the C value for an attribute is a class. So this works: has 'birth_date' => ( is => 'ro', isa => 'DateTime', ); In general, when Moose is presented with an unknown name, it assumes that the name is a class: subtype 'ModernDateTime' => as 'DateTime' => where { $_->year() >= 1980 } => message { 'The date you provided is not modern enough' }; has 'valid_dates' => ( is => 'ro', isa => 'ArrayRef[DateTime]', ); Moose will assume that C is a class name in both of these instances. =head1 SUBTYPES Moose uses subtypes in its built-in hierarchy. For example, C is a child of C. A subtype is defined in terms of a parent type and a constraint. Any constraints defined by the parent(s) will be checked first, followed by constraints defined by the subtype. A value must pass I of these checks to be valid for the subtype. Typically, a subtype takes the parent's constraint and makes it more specific. A subtype can also define its own constraint failure message. This lets you do things like have an error "The value you provided (20), was not a valid rating, which must be a number from 1-10." This is much friendlier than the default error, which just says that the value failed a validation check for the type. The default error can, however, be made more friendly by installing L (version 0.14 or higher), which Moose will use if possible to display the invalid value. Here's a simple (and useful) subtype example: subtype 'PositiveInt', as 'Int', where { $_ > 0 }, message { "The number you provided, $_, was not a positive number" }; Note that the sugar functions for working with types are all exported by L. =head1 TYPE NAMES Type names are global throughout the current Perl interpreter. Internally, Moose maps names to type objects via a L. If you have multiple apps or libraries all using Moose in the same process, you could have problems with collisions. We recommend that you prefix names with some sort of namespace indicator to prevent these sorts of collisions. For example, instead of calling a type "PositiveInt", call it "MyApp::Type::PositiveInt" or "MyApp::Types::PositiveInt". We recommend that you centralize all of these definitions in a single package, C, which can be loaded by other classes in your application. However, before you do this, you should look at the L module. This module makes it easy to create a "type library" module, which can export your types as perl constants. has 'counter' => (is => 'rw', isa => PositiveInt); This lets you use a short name rather than needing to fully qualify the name everywhere. It also allows you to easily create parameterized types: has 'counts' => (is => 'ro', isa => HashRef[PositiveInt]); This module will check your names at compile time, and is generally more robust than the string type parsing for complex cases. =head1 COERCION A coercion lets you tell Moose to automatically convert one type to another. subtype 'ArrayRefOfInts', as 'ArrayRef[Int]'; coerce 'ArrayRefOfInts', from 'Int', via { [ $_ ] }; You'll note that we created a subtype rather than coercing C directly. It's a bad idea to add coercions to the raw built in types. Coercions are global, just like type names, so a coercion applied to a built in type is seen by all modules using Moose types. This is I reason why it is good to namespace your types. Moose will I try to coerce a value unless you explicitly ask for it. This is done by setting the C attribute option to a true value: package Foo; has 'sizes' => ( is => 'ro', isa => 'ArrayRefOfInts', coerce => 1, ); Foo->new( sizes => 42 ); This code example will do the right thing, and the newly created object will have C<[ 42 ]> as its C attribute. =head2 Deep coercion Deep coercion is the coercion of type parameters for parameterized types. Let's take these types as an example: subtype 'HexNum', as 'Str', where { /[a-f0-9]/i }; coerce 'Int', from 'HexNum', via { hex $_ }; has 'sizes' => ( is => 'ro', isa => 'ArrayRef[Int]', coerce => 1, ); If we try passing an array reference of hex numbers for the C attribute, Moose will not do any coercion. However, you can define a set of subtypes to enable coercion between two parameterized types. subtype 'ArrayRefOfHexNums', as 'ArrayRef[HexNum]'; subtype 'ArrayRefOfInts', as 'ArrayRef[Int]'; coerce 'ArrayRefOfInts', from 'ArrayRefOfHexNums', via { [ map { hex } @{$_} ] }; Foo->new( sizes => [ 'a1', 'ff', '22' ] ); Now Moose will coerce the hex numbers to integers. Moose does not attempt to chain coercions, so it will not coerce a single hex number. To do that, we need to define a separate coercion: coerce 'ArrayRefOfInts', from 'HexNum', via { [ hex $_ ] }; Yes, this can all get verbose, but coercion is tricky magic, and we think it's best to make it explicit. =head1 TYPE UNIONS Moose allows you to say that an attribute can be of two or more disparate types. For example, we might allow an C or C: has 'output' => ( is => 'rw', isa => 'Object | FileHandle', ); Moose actually parses that string and recognizes that you are creating a type union. The C attribute will accept any sort of object, as well as an unblessed file handle. It is up to you to do the right thing for each of them in your code. Whenever you use a type union, you should consider whether or not coercion might be a better answer. For our example above, we might want to be more specific, and insist that output be an object with a C method: duck_type 'CanPrint', [qw(print)]; We can coerce file handles to an object that satisfies this condition with a simple wrapper class: package FHWrapper; use Moose; has 'handle' => ( is => 'rw', isa => 'FileHandle', ); sub print { my $self = shift; my $fh = $self->handle(); print {$fh} @_; } Now we can define a coercion from C to our wrapper class: coerce 'CanPrint' => from 'FileHandle' => via { FHWrapper->new( handle => $_ ) }; has 'output' => ( is => 'rw', isa => 'CanPrint', coerce => 1, ); This pattern of using a coercion instead of a type union will help make your class internals simpler. =head1 TYPE CREATION HELPERS The L module exports a number of helper functions for creating specific kinds of types. These include C, C, C, and C. See the docs for details. One helper worth noting is C, which allows you to create a subtype of C that only allows the specified values: enum 'RGB', [qw( red green blue )]; This creates a type named C. =head1 ANONYMOUS TYPES All of the type creation functions return a type object. This type object can be used wherever you would use a type name, as a parent type, or as the value for an attribute's C option: has 'size' => ( is => 'ro', isa => subtype( 'Int' => where { $_ > 0 } ), ); This is handy when you want to create a one-off type and don't want to "pollute" the global namespace registry. =head1 VALIDATING METHOD PARAMETERS Moose does not provide any means of validating method parameters. However, there are several MooseX extensions on CPAN which let you do this. The simplest and least sugary is L. This lets you validate a set of named parameters using Moose types: use Moose; use MooseX::Params::Validate; sub foo { my $self = shift; my %params = validated_hash( \@_, bar => { isa => 'Str', default => 'Moose' }, ); ... } L also supports coercions. There are several more powerful extensions that support method parameter validation using Moose types, including L, which gives you a full-blown C keyword. method morning ( Str $name ) { $self->say("Good morning ${name}!"); } =head1 LOAD ORDER ISSUES Because Moose types are defined at runtime, you may run into load order problems. In particular, you may want to use a class's type constraint before that type has been defined. In order to ameliorate this problem, we recommend defining I of your custom types in one module, C, and then loading this module in all of your other modules. =head1 AUTHOR Moose is maintained by the Moose Cabal, along with the help of many contributors. See L and L for details. =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2013 by Infinity Interactive, Inc.. This is free software; you can redistribute it and/or modify it under the same terms as the Perl 5 programming language system itself. =cut Instance.pm100644000767000024 276012200352344 17161 0ustar00etherstaff000000000000Moose-2.1005/lib/Moose/Meta package Moose::Meta::Instance; BEGIN { $Moose::Meta::Instance::AUTHORITY = 'cpan:STEVAN'; } { $Moose::Meta::Instance::VERSION = '2.1005'; } use strict; use warnings; use Class::MOP::MiniTrait; use base "Class::MOP::Instance"; Class::MOP::MiniTrait::apply(__PACKAGE__, 'Moose::Meta::Object::Trait'); 1; # ABSTRACT: The Moose Instance metaclass __END__ =pod =head1 NAME Moose::Meta::Instance - The Moose Instance metaclass =head1 VERSION version 2.1005 =head1 SYNOPSIS # nothing to see here =head1 DESCRIPTION This class provides the low level data storage abstractions for attributes. Using this API directly in your own code violates encapsulation, and we recommend that you use the appropriate APIs in L and L instead. Those APIs in turn call the methods in this class as appropriate. At present, this is an empty subclass of L, so you should see that class for all API details. =head1 INHERITANCE C is a subclass of L. =head1 BUGS See L for details on reporting bugs. =head1 AUTHOR Moose is maintained by the Moose Cabal, along with the help of many contributors. See L and L for details. =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2013 by Infinity Interactive, Inc.. This is free software; you can redistribute it and/or modify it under the same terms as the Perl 5 programming language system itself. =cut Util000755000767000024 012200352344 14741 5ustar00etherstaff000000000000Moose-2.1005/lib/MooseMetaRole.pm100644000767000024 1625412200352344 17177 0ustar00etherstaff000000000000Moose-2.1005/lib/Moose/Utilpackage Moose::Util::MetaRole; BEGIN { $Moose::Util::MetaRole::AUTHORITY = 'cpan:STEVAN'; } { $Moose::Util::MetaRole::VERSION = '2.1005'; } use strict; use warnings; use Scalar::Util 'blessed'; use Carp qw( croak ); use List::MoreUtils qw( all ); use List::Util qw( first ); use Moose::Deprecated; use Scalar::Util qw( blessed ); sub apply_metaroles { my %args = @_; my $for = _metathing_for( $args{for} ); if ( $for->isa('Moose::Meta::Role') ) { return _make_new_metaclass( $for, $args{role_metaroles}, 'role' ); } else { return _make_new_metaclass( $for, $args{class_metaroles}, 'class' ); } } sub _metathing_for { my $passed = shift; my $found = blessed $passed ? $passed : Class::MOP::class_of($passed); return $found if defined $found && blessed $found && ( $found->isa('Moose::Meta::Role') || $found->isa('Moose::Meta::Class') ); local $Carp::CarpLevel = $Carp::CarpLevel + 1; my $error_start = 'When using Moose::Util::MetaRole, you must pass a Moose class name,' . ' role name, metaclass object, or metarole object.'; if ( defined $found && blessed $found ) { croak $error_start . " You passed $passed, and we resolved this to a " . ( blessed $found ) . ' object.'; } if ( defined $passed && !defined $found ) { croak $error_start . " You passed $passed, and this did not resolve to a metaclass or metarole." . ' Maybe you need to call Moose->init_meta to initialize the metaclass first?'; } if ( !defined $passed ) { croak $error_start . " You passed an undef." . ' Maybe you need to call Moose->init_meta to initialize the metaclass first?'; } } sub _make_new_metaclass { my $for = shift; my $roles = shift; my $primary = shift; return $for unless keys %{$roles}; my $new_metaclass = exists $roles->{$primary} ? _make_new_class( ref $for, $roles->{$primary} ) : blessed $for; my %classes; for my $key ( grep { $_ ne $primary } keys %{$roles} ) { my $attr = first {$_} map { $for->meta->find_attribute_by_name($_) } ( $key . '_metaclass', $key . '_class' ); my $reader = $attr->get_read_method; $classes{ $attr->init_arg } = _make_new_class( $for->$reader(), $roles->{$key} ); } my $new_meta = $new_metaclass->reinitialize( $for, %classes ); return $new_meta; } sub apply_base_class_roles { my %args = @_; my $meta = _metathing_for( $args{for} || $args{for_class} ); croak 'You can only apply base class roles to a Moose class, not a role.' if $meta->isa('Moose::Meta::Role'); my $new_base = _make_new_class( $meta->name, $args{roles}, [ $meta->superclasses() ], ); $meta->superclasses($new_base) if $new_base ne $meta->name(); } sub _make_new_class { my $existing_class = shift; my $roles = shift; my $superclasses = shift || [$existing_class]; return $existing_class unless $roles; my $meta = Class::MOP::Class->initialize($existing_class); return $existing_class if $meta->can('does_role') && all { $meta->does_role($_) } grep { !ref $_ } @{$roles}; return Moose::Meta::Class->create_anon_class( superclasses => $superclasses, roles => $roles, cache => 1, )->name(); } 1; # ABSTRACT: Apply roles to any metaclass, as well as the object base class __END__ =pod =head1 NAME Moose::Util::MetaRole - Apply roles to any metaclass, as well as the object base class =head1 VERSION version 2.1005 =head1 SYNOPSIS package MyApp::Moose; use Moose (); use Moose::Exporter; use Moose::Util::MetaRole; use MyApp::Role::Meta::Class; use MyApp::Role::Meta::Method::Constructor; use MyApp::Role::Object; Moose::Exporter->setup_import_methods( also => 'Moose' ); sub init_meta { shift; my %args = @_; Moose->init_meta(%args); Moose::Util::MetaRole::apply_metaroles( for => $args{for_class}, class_metaroles => { class => => ['MyApp::Role::Meta::Class'], constructor => ['MyApp::Role::Meta::Method::Constructor'], }, ); Moose::Util::MetaRole::apply_base_class_roles( for => $args{for_class}, roles => ['MyApp::Role::Object'], ); return $args{for_class}->meta(); } =head1 DESCRIPTION This utility module is designed to help authors of Moose extensions write extensions that are able to cooperate with other Moose extensions. To do this, you must write your extensions as roles, which can then be dynamically applied to the caller's metaclasses. This module makes sure to preserve any existing superclasses and roles already set for the meta objects, which means that any number of extensions can apply roles in any order. =head1 USAGE The easiest way to use this module is through L, which can generate the appropriate C method for you, and make sure it is called when imported. =head1 FUNCTIONS This module provides two functions. =head2 apply_metaroles( ... ) This function will apply roles to one or more metaclasses for the specified class. It will return a new metaclass object for the class or role passed in the "for" parameter. It accepts the following parameters: =over 4 =item * for => $name This specifies the class or for which to alter the meta classes. This can be a package name, or an appropriate meta-object (a L or L). =item * class_metaroles => \%roles This is a hash reference specifying which metaroles will be applied to the class metaclass and its contained metaclasses and helper classes. Each key should in turn point to an array reference of role names. It accepts the following keys: =over 8 =item class =item attribute =item method =item wrapped_method =item instance =item constructor =item destructor =item error =back =item * role_metaroles => \%roles This is a hash reference specifying which metaroles will be applied to the role metaclass and its contained metaclasses and helper classes. It accepts the following keys: =over 8 =item role =item attribute =item method =item required_method =item conflicting_method =item application_to_class =item application_to_role =item application_to_instance =item application_role_summation =item applied_attribute =back =back =head2 apply_base_class_roles( for => $class, roles => \@roles ) This function will apply the specified roles to the object's base class. =head1 BUGS See L for details on reporting bugs. =head1 AUTHOR Moose is maintained by the Moose Cabal, along with the help of many contributors. See L and L for details. =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2013 by Infinity Interactive, Inc.. This is free software; you can redistribute it and/or modify it under the same terms as the Perl 5 programming language system itself. =cut no_init_arg.t100644000767000024 73712200352344 17431 0ustar00etherstaff000000000000Moose-2.1005/t/attributes#!/usr/bin/perl use strict; use warnings; use Test::More; { package Foo; use Moose; eval { has 'foo' => ( is => "rw", init_arg => undef, ); }; ::ok(!$@, '... created the attr okay'); } { my $foo = Foo->new( foo => "bar" ); isa_ok($foo, 'Foo'); is( $foo->foo, undef, "field is not set via init arg" ); $foo->foo("blah"); is( $foo->foo, "blah", "field is set via setter" ); } done_testing; import_unimport.t100644000767000024 254712200352344 17507 0ustar00etherstaff000000000000Moose-2.1005/t/basics#!/usr/bin/perl use strict; use warnings; use Test::More; my @moose_exports = qw( extends with has before after around override augment super inner blessed confess ); { package Foo; eval 'use Moose'; die $@ if $@; } can_ok('Foo', $_) for @moose_exports; { package Foo; eval 'no Moose'; die $@ if $@; } ok(!Foo->can($_), '... Foo can no longer do ' . $_) for @moose_exports; # and check the type constraints as well my @moose_type_constraint_exports = qw( type subtype as where message coerce from via enum find_type_constraint ); { package Bar; eval 'use Moose::Util::TypeConstraints'; die $@ if $@; } can_ok('Bar', $_) for @moose_type_constraint_exports; { package Bar; eval 'no Moose::Util::TypeConstraints'; die $@ if $@; } ok(!Bar->can($_), '... Bar can no longer do ' . $_) for @moose_type_constraint_exports; { package Baz; use Moose; use Scalar::Util qw( blessed ); no Moose; } can_ok( 'Baz', 'blessed' ); { package Moo; use Scalar::Util qw( blessed ); use Moose; no Moose; } can_ok( 'Moo', 'blessed' ); my $blessed; { package Quux; use Scalar::Util qw( blessed ); use Moose blessed => { -as => \$blessed }; no Moose; } can_ok( 'Quux', 'blessed' ); is( $blessed, \&Scalar::Util::blessed ); done_testing; inline_reader_bug.t100644000767000024 66512200352344 17350 0ustar00etherstaff000000000000Moose-2.1005/t/bugs#!/usr/bin/perl use strict; use warnings; use Test::More; use Test::Fatal; =pod This was a bug, but it is fixed now. This test makes sure it does not creep back in. =cut { package Foo; use Moose; ::is( ::exception { has 'bar' => ( is => 'ro', isa => 'Int', lazy => 1, default => 10, ); }, undef, '... this didnt die' ); } done_testing; subtype_quote_bug.t100644000767000024 76312200352344 17457 0ustar00etherstaff000000000000Moose-2.1005/t/bugs#!/usr/bin/perl use strict; use warnings; use Test::More; =pod This is a test for a bug found by Purge on #moose: The code: subtype Stuff => as Object => where { ... } will break if the Object:: namespace exists. So the solution is to quote 'Object', like so: subtype Stuff => as 'Object' => where { ... } Moose 0.03 did this, now it doesn't, so all should be well from now on. =cut { package Object::Test; } { package Foo; ::use_ok('Moose'); } done_testing; class_is_pristine.t100644000767000024 72612200352344 17424 0ustar00etherstaff000000000000Moose-2.1005/t/cmopuse strict; use warnings; use Class::MOP; use Test::More; { package Foo; sub foo { } sub bar { } } my $meta = Class::MOP::Class->initialize('Foo'); ok( $meta->is_pristine, 'Foo is still pristine' ); $meta->add_method( baz => sub { } ); ok( $meta->is_pristine, 'Foo is still pristine after add_method' ); $meta->add_attribute( name => 'attr', reader => 'get_attr' ); ok( ! $meta->is_pristine, 'Foo is not pristine after add_attribute' ); done_testing; constant_codeinfo.t100644000767000024 67112200352344 17405 0ustar00etherstaff000000000000Moose-2.1005/t/cmopuse strict; use warnings; use Test::More; use Class::MOP; { package Foo; use constant FOO => 'bar'; } my $meta = Class::MOP::Class->initialize('Foo'); my $syms = $meta->get_all_package_symbols('CODE'); is(ref $syms->{FOO}, 'CODE', 'get constant symbol'); undef $syms; $syms = $meta->get_all_package_symbols('CODE'); is(ref $syms->{FOO}, 'CODE', 'constant symbol still there, although we dropped our reference'); done_testing; package_variables.t100644000767000024 2020612200352344 17365 0ustar00etherstaff000000000000Moose-2.1005/t/cmopuse strict; use warnings; use Test::More; use Test::Fatal; use Class::MOP; { package Foo; use metaclass; } =pod This is the same test as 080_meta_package.t just here we call all the methods through Class::MOP::Class. =cut # ---------------------------------------------------------------------- ## tests adding a HASH ok(!defined($Foo::{foo}), '... the %foo slot has not been created yet'); ok(!Foo->meta->has_package_symbol('%foo'), '... the meta agrees'); is( exception { Foo->meta->add_package_symbol('%foo' => { one => 1 }); }, undef, '... created %Foo::foo successfully' ); # ... scalar should NOT be created here ok(!Foo->meta->has_package_symbol('$foo'), '... SCALAR shouldnt have been created too'); ok(!Foo->meta->has_package_symbol('@foo'), '... ARRAY shouldnt have been created too'); ok(!Foo->meta->has_package_symbol('&foo'), '... CODE shouldnt have been created too'); ok(defined($Foo::{foo}), '... the %foo slot was created successfully'); ok(Foo->meta->has_package_symbol('%foo'), '... the meta agrees'); # check the value ... { no strict 'refs'; ok(exists ${'Foo::foo'}{one}, '... our %foo was initialized correctly'); is(${'Foo::foo'}{one}, 1, '... our %foo was initialized correctly'); } my $foo = Foo->meta->get_package_symbol('%foo'); is_deeply({ one => 1 }, $foo, '... got the right package variable back'); # ... make sure changes propogate up $foo->{two} = 2; { no strict 'refs'; is(\%{'Foo::foo'}, Foo->meta->get_package_symbol('%foo'), '... our %foo is the same as the metas'); ok(exists ${'Foo::foo'}{two}, '... our %foo was updated correctly'); is(${'Foo::foo'}{two}, 2, '... our %foo was updated correctly'); } # ---------------------------------------------------------------------- ## test adding an ARRAY ok(!defined($Foo::{bar}), '... the @bar slot has not been created yet'); is( exception { Foo->meta->add_package_symbol('@bar' => [ 1, 2, 3 ]); }, undef, '... created @Foo::bar successfully' ); ok(defined($Foo::{bar}), '... the @bar slot was created successfully'); ok(Foo->meta->has_package_symbol('@bar'), '... the meta agrees'); # ... why does this not work ... ok(!Foo->meta->has_package_symbol('$bar'), '... SCALAR shouldnt have been created too'); ok(!Foo->meta->has_package_symbol('%bar'), '... HASH shouldnt have been created too'); ok(!Foo->meta->has_package_symbol('&bar'), '... CODE shouldnt have been created too'); # check the value itself { no strict 'refs'; is(scalar @{'Foo::bar'}, 3, '... our @bar was initialized correctly'); is(${'Foo::bar'}[1], 2, '... our @bar was initialized correctly'); } # ---------------------------------------------------------------------- ## test adding a SCALAR ok(!defined($Foo::{baz}), '... the $baz slot has not been created yet'); is( exception { Foo->meta->add_package_symbol('$baz' => 10); }, undef, '... created $Foo::baz successfully' ); ok(defined($Foo::{baz}), '... the $baz slot was created successfully'); ok(Foo->meta->has_package_symbol('$baz'), '... the meta agrees'); ok(!Foo->meta->has_package_symbol('@baz'), '... ARRAY shouldnt have been created too'); ok(!Foo->meta->has_package_symbol('%baz'), '... HASH shouldnt have been created too'); ok(!Foo->meta->has_package_symbol('&baz'), '... CODE shouldnt have been created too'); is(${Foo->meta->get_package_symbol('$baz')}, 10, '... got the right value back'); { no strict 'refs'; ${'Foo::baz'} = 1; is(${'Foo::baz'}, 1, '... our $baz was assigned to correctly'); is(${Foo->meta->get_package_symbol('$baz')}, 1, '... the meta agrees'); } # ---------------------------------------------------------------------- ## test adding a CODE ok(!defined($Foo::{funk}), '... the &funk slot has not been created yet'); is( exception { Foo->meta->add_package_symbol('&funk' => sub { "Foo::funk" }); }, undef, '... created &Foo::funk successfully' ); ok(defined($Foo::{funk}), '... the &funk slot was created successfully'); ok(Foo->meta->has_package_symbol('&funk'), '... the meta agrees'); ok(!Foo->meta->has_package_symbol('$funk'), '... SCALAR shouldnt have been created too'); ok(!Foo->meta->has_package_symbol('@funk'), '... ARRAY shouldnt have been created too'); ok(!Foo->meta->has_package_symbol('%funk'), '... HASH shouldnt have been created too'); { no strict 'refs'; ok(defined &{'Foo::funk'}, '... our &funk exists'); } is(Foo->funk(), 'Foo::funk', '... got the right value from the function'); # ---------------------------------------------------------------------- ## test multiple slots in the glob my $ARRAY = [ 1, 2, 3 ]; my $CODE = sub { "Foo::foo" }; is( exception { Foo->meta->add_package_symbol('@foo' => $ARRAY); }, undef, '... created @Foo::foo successfully' ); ok(Foo->meta->has_package_symbol('@foo'), '... the @foo slot was added successfully'); is(Foo->meta->get_package_symbol('@foo'), $ARRAY, '... got the right values for @Foo::foo'); is( exception { Foo->meta->add_package_symbol('&foo' => $CODE); }, undef, '... created &Foo::foo successfully' ); ok(Foo->meta->has_package_symbol('&foo'), '... the meta agrees'); is(Foo->meta->get_package_symbol('&foo'), $CODE, '... got the right value for &Foo::foo'); is( exception { Foo->meta->add_package_symbol('$foo' => 'Foo::foo'); }, undef, '... created $Foo::foo successfully' ); ok(Foo->meta->has_package_symbol('$foo'), '... the meta agrees'); my $SCALAR = Foo->meta->get_package_symbol('$foo'); is($$SCALAR, 'Foo::foo', '... got the right scalar value back'); { no strict 'refs'; is(${'Foo::foo'}, 'Foo::foo', '... got the right value from the scalar'); } is( exception { Foo->meta->remove_package_symbol('%foo'); }, undef, '... removed %Foo::foo successfully' ); ok(!Foo->meta->has_package_symbol('%foo'), '... the %foo slot was removed successfully'); ok(Foo->meta->has_package_symbol('@foo'), '... the @foo slot still exists'); ok(Foo->meta->has_package_symbol('&foo'), '... the &foo slot still exists'); ok(Foo->meta->has_package_symbol('$foo'), '... the $foo slot still exists'); is(Foo->meta->get_package_symbol('@foo'), $ARRAY, '... got the right values for @Foo::foo'); is(Foo->meta->get_package_symbol('&foo'), $CODE, '... got the right value for &Foo::foo'); is(Foo->meta->get_package_symbol('$foo'), $SCALAR, '... got the right value for $Foo::foo'); { no strict 'refs'; ok(!defined(*{"Foo::foo"}{HASH}), '... the %foo slot has been removed successfully'); ok(defined(*{"Foo::foo"}{ARRAY}), '... the @foo slot has NOT been removed'); ok(defined(*{"Foo::foo"}{CODE}), '... the &foo slot has NOT been removed'); ok(defined(${"Foo::foo"}), '... the $foo slot has NOT been removed'); } is( exception { Foo->meta->remove_package_symbol('&foo'); }, undef, '... removed &Foo::foo successfully' ); ok(!Foo->meta->has_package_symbol('&foo'), '... the &foo slot no longer exists'); ok(Foo->meta->has_package_symbol('@foo'), '... the @foo slot still exists'); ok(Foo->meta->has_package_symbol('$foo'), '... the $foo slot still exists'); is(Foo->meta->get_package_symbol('@foo'), $ARRAY, '... got the right values for @Foo::foo'); is(Foo->meta->get_package_symbol('$foo'), $SCALAR, '... got the right value for $Foo::foo'); { no strict 'refs'; ok(!defined(*{"Foo::foo"}{HASH}), '... the %foo slot has been removed successfully'); ok(!defined(*{"Foo::foo"}{CODE}), '... the &foo slot has now been removed'); ok(defined(*{"Foo::foo"}{ARRAY}), '... the @foo slot has NOT been removed'); ok(defined(${"Foo::foo"}), '... the $foo slot has NOT been removed'); } is( exception { Foo->meta->remove_package_symbol('$foo'); }, undef, '... removed $Foo::foo successfully' ); ok(!Foo->meta->has_package_symbol('$foo'), '... the $foo slot no longer exists'); ok(Foo->meta->has_package_symbol('@foo'), '... the @foo slot still exists'); is(Foo->meta->get_package_symbol('@foo'), $ARRAY, '... got the right values for @Foo::foo'); { no strict 'refs'; ok(!defined(*{"Foo::foo"}{HASH}), '... the %foo slot has been removed successfully'); ok(!defined(*{"Foo::foo"}{CODE}), '... the &foo slot has now been removed'); ok(!defined(${"Foo::foo"}), '... the $foo slot has now been removed'); ok(defined(*{"Foo::foo"}{ARRAY}), '... the @foo slot has NOT been removed'); } done_testing; universal_methods.t100644000767000024 201312200352344 17451 0ustar00etherstaff000000000000Moose-2.1005/t/cmopuse strict; use warnings; use Test::More; use Class::MOP; my $meta_class = Class::MOP::Class->create_anon_class; my %methods = map { $_->name => 1 } $meta_class->get_all_methods(); my %method_names = map { $_ => 1 } $meta_class->get_all_method_names(); my @universal_methods = qw/isa can VERSION/; push @universal_methods, 'DOES' if $] >= 5.010; for my $method (@universal_methods) { ok( $meta_class->find_method_by_name($method), "find_method_by_name finds UNIVERSAL method $method" ); ok( $meta_class->find_next_method_by_name($method), "find_next_method_by_name finds UNIVERSAL method $method" ); ok( scalar $meta_class->find_all_methods_by_name($method), "find_all_methods_by_name finds UNIVERSAL method $method" ); ok( $methods{$method}, "get_all_methods includes $method from UNIVERSAL" ); ok( $method_names{$method}, "get_all_method_names includes $method from UNIVERSAL" ); } done_testing; example_w_DCS.t100644000767000024 351012200352344 17253 0ustar00etherstaff000000000000Moose-2.1005/t/examples#!/usr/bin/perl use strict; use warnings; use Test::More; =pod This tests how well Moose type constraints play with Declare::Constraints::Simple. Pretty well if I do say so myself :) =cut use Test::Requires { 'Declare::Constraints::Simple' => '0.01', # skip all if not installed }; use Test::Fatal; { package Foo; use Moose; use Moose::Util::TypeConstraints; use Declare::Constraints::Simple -All; # define your own type ... type( 'HashOfArrayOfObjects', { where => IsHashRef( -keys => HasLength, -values => IsArrayRef(IsObject) ) } ); has 'bar' => ( is => 'rw', isa => 'HashOfArrayOfObjects', ); # inline the constraints as anon-subtypes has 'baz' => ( is => 'rw', isa => subtype( { as => 'ArrayRef', where => IsArrayRef(IsInt) } ), ); package Bar; use Moose; } my $hash_of_arrays_of_objs = { foo1 => [ Bar->new ], foo2 => [ Bar->new, Bar->new ], }; my $array_of_ints = [ 1 .. 10 ]; my $foo; is( exception { $foo = Foo->new( 'bar' => $hash_of_arrays_of_objs, 'baz' => $array_of_ints, ); }, undef, '... construction succeeded' ); isa_ok($foo, 'Foo'); is_deeply($foo->bar, $hash_of_arrays_of_objs, '... got our value correctly'); is_deeply($foo->baz, $array_of_ints, '... got our value correctly'); isnt( exception { $foo->bar([]); }, undef, '... validation failed correctly' ); isnt( exception { $foo->bar({ foo => 3 }); }, undef, '... validation failed correctly' ); isnt( exception { $foo->bar({ foo => [ 1, 2, 3 ] }); }, undef, '... validation failed correctly' ); isnt( exception { $foo->baz([ "foo" ]); }, undef, '... validation failed correctly' ); isnt( exception { $foo->baz({}); }, undef, '... validation failed correctly' ); done_testing; NoInlineAttribute.pm100644000767000024 71312200352344 17263 0ustar00etherstaff000000000000Moose-2.1005/t/libpackage NoInlineAttribute; use Moose::Meta::Class; use Moose::Role; around accessor_metaclass => sub { my $orig = shift; my $self = shift; my $class = $self->$orig(); return Moose::Meta::Class->create_anon_class( superclasses => [$class], roles => ['NoInlineAccessor'], cache => 1, )->name; }; no Moose::Role; { package NoInlineAccessor; use Moose::Role; sub is_inline { 0 } } 1; apply_roles.t100644000767000024 240012200352344 17470 0ustar00etherstaff000000000000Moose-2.1005/t/moose_utiluse strict; use warnings; use Test::More; use Moose::Util qw( apply_all_roles ); { package Role::Foo; use Moose::Role; } { package Role::Bar; use Moose::Role; } { package Role::Baz; use Moose::Role; } { package Class::A; use Moose; } { package Class::B; use Moose; } { package Class::C; use Moose; } { package Class::D; use Moose; } { package Class::E; use Moose; } my @roles = qw( Role::Foo Role::Bar Role::Baz ); apply_all_roles( 'Class::A', @roles ); ok( Class::A->meta->does_role($_), "Class::A does $_" ) for @roles; apply_all_roles( 'Class::B', map { $_->meta } @roles ); ok( Class::A->meta->does_role($_), "Class::B does $_ (applied with meta role object)" ) for @roles; @roles = qw( Role::Foo ); apply_all_roles( 'Class::C', @roles ); ok( Class::A->meta->does_role($_), "Class::C does $_" ) for @roles; apply_all_roles( 'Class::D', map { $_->meta } @roles ); ok( Class::A->meta->does_role($_), "Class::D does $_ (applied with meta role object)" ) for @roles; @roles = qw( Role::Foo Role::Bar ), Role::Baz->meta; apply_all_roles( 'Class::E', @roles ); ok( Class::A->meta->does_role($_), "Class::E does $_ (mix of names and meta role object)" ) for @roles; done_testing; with_traits.t100644000767000024 211212200352344 17500 0ustar00etherstaff000000000000Moose-2.1005/t/moose_util#!/usr/bin/env perl use strict; use warnings; use Test::More; use Test::Moose; use Moose (); use Moose::Util qw(with_traits); { package Foo; use Moose; } { package Foo::Role; use Moose::Role; } { package Foo::Role2; use Moose::Role; } { my $traited_class = with_traits('Foo', 'Foo::Role'); ok($traited_class->meta->is_anon_class, "we get an anon class"); isa_ok($traited_class, 'Foo'); does_ok($traited_class, 'Foo::Role'); } { my $traited_class = with_traits('Foo', 'Foo::Role', 'Foo::Role2'); ok($traited_class->meta->is_anon_class, "we get an anon class"); isa_ok($traited_class, 'Foo'); does_ok($traited_class, 'Foo::Role'); does_ok($traited_class, 'Foo::Role2'); } { my $traited_class = with_traits('Foo'); is($traited_class, 'Foo', "don't apply anything if we don't get any traits"); } { my $traited_class = with_traits('Foo', 'Foo::Role'); my $traited_class2 = with_traits('Foo', 'Foo::Role'); is($traited_class, $traited_class2, "get the same class back when passing the same roles"); } done_testing; method_modifiers.t100644000767000024 251312200352344 17432 0ustar00etherstaff000000000000Moose-2.1005/t/roles#!/usr/bin/env perl use strict; use warnings; use Test::More; use Test::Fatal; my $FooRole; { package Foo::Role; use Moose::Role; after foo => sub { $FooRole++ }; } { package Foo; use Moose; with 'Foo::Role'; sub foo { } } Foo->foo; is($FooRole, 1, "modifier called"); my $BarRole; { package Bar::Role; use Moose::Role; after ['foo', 'bar'] => sub { $BarRole++ }; } { package Bar; use Moose; with 'Bar::Role'; sub foo { } sub bar { } } Bar->foo; is($BarRole, 1, "modifier called"); Bar->bar; is($BarRole, 2, "modifier called"); my $BazRole; { package Baz::Role; use Moose::Role; after 'foo', 'bar' => sub { $BazRole++ }; } { package Baz; use Moose; with 'Baz::Role'; sub foo { } sub bar { } } Baz->foo; is($BazRole, 1, "modifier called"); Baz->bar; is($BazRole, 2, "modifier called"); my $QuuxRole; { package Quux::Role; use Moose::Role; { our $TODO; local $TODO = "can't handle regexes yet"; ::is( ::exception { after qr/foo|bar/ => sub { $QuuxRole++ } }, undef ); } } { package Quux; use Moose; with 'Quux::Role'; sub foo { } sub bar { } } { local $TODO = "can't handle regexes yet"; Quux->foo; is($QuuxRole, 1, "modifier called"); Quux->bar; is($QuuxRole, 2, "modifier called"); } done_testing; author000755000767000024 012200352344 13476 5ustar00etherstaff000000000000Moose-2.1005extract-inline-tests100755000767000024 141012200352344 17646 0ustar00etherstaff000000000000Moose-2.1005/author#!/usr/bin/perl use strict; use warnings; use lib 'inc'; use File::Find::Rule; use Getopt::Long; use MyInline; use Test::Inline; my $quiet; GetOptions( 'quiet' => \$quiet ); my $inline = Test::Inline->new( verbose => !$quiet, ExtractHandler => 'My::Extract', ContentHandler => 'My::Content', OutputHandler => 'My::Output', ); for my $pod ( File::Find::Rule->file->name(qr/\.pod$/)->in('lib/Moose/Cookbook') ) { $inline->add($pod); } $inline->save; { package My::Output; use File::Slurp qw( write_file ); sub write { my $class = shift; my $name = shift; my $content = shift; $name =~ s/^moose_cookbook_//; write_file( "t/recipes/$name", $content ); return 1; } } lotsa-classes.pl100644000767000024 473712200352344 17576 0ustar00etherstaff000000000000Moose-2.1005/benchmarks#!/usr/bin/env perl use warnings FATAL => 'all'; use strict; use File::Temp; use Path::Class; my $number_of_classes = shift || 1500; my $number_of_attributes = shift || 20; my $t = shift || File::Temp->newdir; my $tmp = dir($t); $tmp->rmtree; $tmp->mkpath; (-d $tmp) or die "not a dir: $tmp"; #print "$tmp\n"; my %class_writer = ( 'Moose' => sub { my $name = shift; my $attrs = join '', map { "has '$_' => ( is => 'ro', isa => 'Str' );\n" } @_; return qq{package $name;\nuse Moose;\n$attrs\n1;\n__END__\n}; }, 'MooseImmutable' => sub { my $name = shift; my $attrs = join '', map { "has '$_' => ( is => 'ro', isa => 'Str' );\n" } @_; return qq{package $name;\nuse Moose;\n$attrs\n__PACKAGE__->meta->make_immutable;\n1;\n__END__\n}; }, 'Moo' => sub { my $name = shift; my $attrs = join'', map { "has '$_' => ( is => 'ro', isa => 'Str' );\n" } @_; return qq{package $name;\nuse Moo;\n$attrs\n1;\n__END__\n}; }, 'Mo' => sub { my $name = shift; my $attrs = join'', map { "has '$_' => ( is => 'ro', isa => 'Str' );\n" } @_; return qq{package $name;\nuse Mo;\n$attrs\n1;\n__END__\n}; }, 'Mouse' => sub { my $name = shift; my $attrs = join'', map { "has '$_' => ( is => 'ro', isa => 'Str' );\n" } @_; return qq{package $name;\nuse Mouse;\n$attrs\n1;\n__END__\n}; }, 'plain-package' => sub { my $name = shift; my $attrs = join'', map { "sub $_ {}\n" } @_; return qq{package $name;\n$attrs\n1;\n__END__\n}; }, ); my $class_prefix = 'TmpClassThingy'; my %lib_map; my @attribute_names = map { 'a' . $_ } 1 .. $number_of_attributes; for my $module (sort keys %class_writer) { my $lib = $tmp->subdir($module . '-lib'); $lib->mkpath; my $all_fh = $lib->file('All.pm')->openw; for my $n (1 .. $number_of_classes) { my $class_name = $class_prefix . $n; my $fh = $lib->file($class_name . '.pm')->openw; $fh->say($class_writer{$module}->($class_name, @attribute_names)) or die; $fh->close or die; $all_fh->say("use $class_name;") or die; } $all_fh->say('1;') or die; $all_fh->close or die; $lib_map{$module} = $lib; } #$DB::single = 1; for my $module (sort keys %lib_map) { my $lib = $lib_map{$module}; print "$module\n"; my $cmd = "time -p $^X -I$lib -MAll -e '1'"; `$cmd > /dev/null 2>&1`; # to cache # print "$cmd\n"; system($cmd); print "\n"; } InsideOutClass.pod100644000767000024 1246112200352344 17573 0ustar00etherstaff000000000000Moose-2.1005/examples package # hide the package from PAUSE InsideOutClass::Attribute; use strict; use warnings; our $VERSION = '0.02'; use Carp 'confess'; use Scalar::Util 'refaddr'; use base 'Class::MOP::Attribute'; sub initialize_instance_slot { my ($self, $meta_instance, $instance, $params) = @_; my $init_arg = $self->init_arg; # try to fetch the init arg from the %params ... my $val; $val = $params->{$init_arg} if exists $params->{$init_arg}; # if nothing was in the %params, we can use the # attribute's default value (if it has one) if (!defined $val && defined $self->default) { $val = $self->default($instance); } my $_meta_instance = $self->associated_class->get_meta_instance; $_meta_instance->initialize_slot($instance, $self->name); $_meta_instance->set_slot_value($instance, $self->name, $val); } sub accessor_metaclass { 'InsideOutClass::Method::Accessor' } package # hide the package from PAUSE InsideOutClass::Method::Accessor; use strict; use warnings; our $VERSION = '0.01'; use Carp 'confess'; use Scalar::Util 'refaddr'; use base 'Class::MOP::Method::Accessor'; ## Method generation helpers sub _generate_accessor_method { my $attr = (shift)->associated_attribute; my $meta_class = $attr->associated_class; my $attr_name = $attr->name; return sub { my $meta_instance = $meta_class->get_meta_instance; $meta_instance->set_slot_value($_[0], $attr_name, $_[1]) if scalar(@_) == 2; $meta_instance->get_slot_value($_[0], $attr_name); }; } sub _generate_reader_method { my $attr = (shift)->associated_attribute; my $meta_class = $attr->associated_class; my $attr_name = $attr->name; return sub { confess "Cannot assign a value to a read-only accessor" if @_ > 1; $meta_class->get_meta_instance ->get_slot_value($_[0], $attr_name); }; } sub _generate_writer_method { my $attr = (shift)->associated_attribute; my $meta_class = $attr->associated_class; my $attr_name = $attr->name; return sub { $meta_class->get_meta_instance ->set_slot_value($_[0], $attr_name, $_[1]); }; } sub _generate_predicate_method { my $attr = (shift)->associated_attribute; my $meta_class = $attr->associated_class; my $attr_name = $attr->name; return sub { defined $meta_class->get_meta_instance ->get_slot_value($_[0], $attr_name) ? 1 : 0; }; } package # hide the package from PAUSE InsideOutClass::Instance; use strict; use warnings; our $VERSION = '0.01'; use Carp 'confess'; use Scalar::Util 'refaddr'; use base 'Class::MOP::Instance'; sub create_instance { my ($self, $class) = @_; bless \(my $instance), $self->_class_name; } sub get_slot_value { my ($self, $instance, $slot_name) = @_; $self->associated_metaclass->get_package_symbol('%' . $slot_name)->{refaddr $instance}; } sub set_slot_value { my ($self, $instance, $slot_name, $value) = @_; $self->associated_metaclass->get_package_symbol('%' . $slot_name)->{refaddr $instance} = $value; } sub initialize_slot { my ($self, $instance, $slot_name) = @_; $self->associated_metaclass->add_package_symbol(('%' . $slot_name) => {}) unless $self->associated_metaclass->has_package_symbol('%' . $slot_name); $self->associated_metaclass->get_package_symbol('%' . $slot_name)->{refaddr $instance} = undef; } sub is_slot_initialized { my ($self, $instance, $slot_name) = @_; return 0 unless $self->associated_metaclass->has_package_symbol('%' . $slot_name); return exists $self->associated_metaclass->get_package_symbol('%' . $slot_name)->{refaddr $instance} ? 1 : 0; } 1; __END__ =pod =head1 NAME InsideOutClass - A set of example metaclasses which implement the Inside-Out technique =head1 SYNOPSIS package Foo; use metaclass ( ':attribute_metaclass' => 'InsideOutClass::Attribute', ':instance_metaclass' => 'InsideOutClass::Instance' ); __PACKAGE__->meta->add_attribute('foo' => ( reader => 'get_foo', writer => 'set_foo' )); sub new { my $class = shift; $class->meta->new_object(@_); } # now you can just use the class as normal =head1 DESCRIPTION This is a set of example metaclasses which implement the Inside-Out class technique. What follows is a brief explaination of the code found in this module. We must create a subclass of B and override the slot operations. This requires overloading C, C, C, and C, as well as their inline counterparts. Additionally we overload C in order to initialize the global hash containing the actual slot values. And that is pretty much all. Of course I am ignoring need for inside-out objects to be C-ed, and some other details as well (threading, etc), but this is an example. A real implementation is left as an exercise to the reader. =head1 AUTHORS Stevan Little Estevan@iinteractive.comE Yuval Kogman Enothingmuch@woobling.comE =head1 COPYRIGHT AND LICENSE Copyright 2006-2008 by Infinity Interactive, Inc. L This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut Perl6Attribute.pod100644000767000024 375012200352344 17537 0ustar00etherstaff000000000000Moose-2.1005/examples package # hide the package from PAUSE Perl6Attribute; use strict; use warnings; our $VERSION = '0.02'; use base 'Class::MOP::Attribute'; Perl6Attribute->meta->add_around_method_modifier('new' => sub { my $cont = shift; my ($class, $attribute_name, %options) = @_; # extract the sigil and accessor name my ($sigil, $accessor_name) = ($attribute_name =~ /^([\$\@\%])\.(.*)$/); # pass the accessor name $options{accessor} = $accessor_name; # create a default value based on the sigil $options{default} = sub { [] } if ($sigil eq '@'); $options{default} = sub { {} } if ($sigil eq '%'); $cont->($class, $attribute_name, %options); }); 1; __END__ =pod =head1 NAME Perl6Attribute - An example attribute metaclass for Perl 6 style attributes =head1 SYNOPSIS package Foo; Foo->meta->add_attribute(Perl6Attribute->new('$.foo')); Foo->meta->add_attribute(Perl6Attribute->new('@.bar')); Foo->meta->add_attribute(Perl6Attribute->new('%.baz')); sub new { my $class = shift; $class->meta->new_object(@_); } =head1 DESCRIPTION This is an attribute metaclass which implements Perl 6 style attributes, including the auto-generating accessors. This code is very simple, we only need to subclass C and override C<&new>. Then we just pre-process the attribute name, and create the accessor name and default value based on it. More advanced features like the C trait (see L) can be accomplished as well doing the same pre-processing approach. This is left as an exercise to the reader though (if you do it, please send me a patch though, and will update this). =head1 AUTHORS Stevan Little Estevan@iinteractive.comE Yuval Kogman Enothingmuch@woobling.comE =head1 COPYRIGHT AND LICENSE Copyright 2006-2008 by Infinity Interactive, Inc. L This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut Deprecated.pm100644000767000024 226412200352344 17204 0ustar00etherstaff000000000000Moose-2.1005/lib/Class/MOPpackage Class::MOP::Deprecated; BEGIN { $Class::MOP::Deprecated::AUTHORITY = 'cpan:STEVAN'; } { $Class::MOP::Deprecated::VERSION = '2.1005'; } use strict; use warnings; use Package::DeprecationManager -deprecations => { }; 1; # ABSTRACT: Manages deprecation warnings for Class::MOP __END__ =pod =head1 NAME Class::MOP::Deprecated - Manages deprecation warnings for Class::MOP =head1 VERSION version 2.1005 =head1 DESCRIPTION use Class::MOP::Deprecated -api_version => $version; =head1 FUNCTIONS This module manages deprecation warnings for features that have been deprecated in Class::MOP. If you specify C<< -api_version => $version >>, you can use deprecated features without warnings. Note that this special treatment is limited to the package that loads C. =head1 AUTHOR Moose is maintained by the Moose Cabal, along with the help of many contributors. See L and L for details. =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2013 by Infinity Interactive, Inc.. This is free software; you can redistribute it and/or modify it under the same terms as the Perl 5 programming language system itself. =cut MooseX.pod100644000767000024 1727612200352344 17354 0ustar00etherstaff000000000000Moose-2.1005/lib/Moose/Manualpackage Moose::Manual::MooseX; # ABSTRACT: Recommended Moose extensions __END__ =pod =head1 NAME Moose::Manual::MooseX - Recommended Moose extensions =head1 VERSION version 2.1005 =head1 MooseX? It's easy to extend and change Moose, and this is part of what makes Moose so powerful. You can use the MOP API to do things your own way, add new features, and generally customize your Moose. Writing your own extensions does require a good understanding of the meta-model. You can start learning about this with the L docs. There are also several extension recipes in the L. Explaining how to write extensions is beyond the scope of this manual. Fortunately, lots of people have already written extensions and put them on CPAN for you. This document covers a few of the ones we like best. =head1 L The functionality of this MooseX module has been moved into Moose core. See L. =head1 L MooseX::AttributeHelpers, but turned inside out, Moose::Autobox provides methods on both arrays/hashes/etc. but also references to them, using Moose roles, allowing you do to things like: use Moose::Autobox; $somebody_elses_object->orders->push($order); Lexically scoped and not to everybody's taste, but very handy for sugaring up other people's APIs and your own code. =head1 L By default, Moose lets you pass any old junk into a class's constructor. If you load L, your class will throw an error if it sees something it doesn't recognize; package User; use Moose; use MooseX::StrictConstructor; has 'name'; has 'email'; User->new( name => 'Bob', emali => 'bob@example.com' ); With L, that typo ("emali") will cause a runtime error. With plain old Moose, the "emali" attribute would be silently ignored. =head1 L We have high hopes for the future of L and L. However, these modules, while used regularly in production by some of the more insane members of the community, are still marked alpha just in case backwards incompatible changes need to be made. If you don't want to risk that, for now we recommend the decidedly more clunky (but also faster and simpler) L. This module lets you apply Moose types and coercions to any method arguments. package User; use Moose; use MooseX::Params::Validate; sub login { my $self = shift; my ($password) = validated_list( \@_, password => { isa => 'Str', required => 1 } ); ... } =head1 L This is a role which adds a C method to your class. This is a constructor that takes the command line options and uses them to populate attributes. This makes writing a command-line application as a module trivially simple: package App::Foo; use Moose; with 'MooseX::Getopt'; has 'input' => ( is => 'ro', isa => 'Str', required => 1 ); has 'output' => ( is => 'ro', isa => 'Str', required => 1 ); sub run { ... } Then in the script that gets run we have: use App::Foo; App::Foo->new_with_options->run; From the command line, someone can execute the script: foo@example> foo --input /path/to/input --output /path/to/output =head1 L To be honest, using a singleton is just a way to have a magic global variable in languages that don't actually have global variables. In perl, you can just as easily use a global. However, if your colleagues are Java-infected, they might prefer a singleton. Also, if you have an existing class that I a singleton but should be, using L is the easiest way to convert it. package Config; use MooseX::Singleton; # instead of Moose has 'cache_dir' => ( ... ); It's that simple. =head1 EXTENSIONS TO CONSIDER There are literally dozens of other extensions on CPAN. This is a list of extensions that you might find useful, but we're not quite ready to endorse just yet. =head2 L Extends Perl with Moose-based keywords using C. Very cool, but still new and experimental. class User { has 'name' => ( ... ); has 'email' => ( ... ); method login (Str $password) { ... } } =head2 L This extension helps you build a type library for your application. It also lets you predeclare type names and use them as barewords. use MooseX::Types -declare => ['PositiveInt']; use MooseX::Types::Moose 'Int'; subtype PositiveInt, as Int, where { $_ > 0 }, message { "Int is not larger than 0" }; One nice feature is that those bareword names are actually namespaced in Moose's type registry, so multiple applications can use the same bareword names, even if the type definitions differ. =head2 L This extension builds on top of L to let you declare complex data structure types. use MooseX::Types -declare => [ qw( Name Color ) ]; use MooseX::Types::Moose qw(Str Int); use MooseX::Types::Structured qw(Dict Tuple Optional); subtype Name => as Dict[ first => Str, middle => Optional[Str], last => Str ]; subtype Color => as Tuple[ Int, Int, Int, Optional[Int] ]; Of course, you could always use objects to represent these sorts of things too. =head2 L This extension provides class attributes for Moose classes. The declared class attributes are introspectable just like regular Moose attributes. package User; use Moose; use MooseX::ClassAttribute; has 'name' => ( ... ); class_has 'Cache' => ( ... ); Note however that this class attribute does I inherit like a L or similar attribute - calling $subclass->Cache($cache); will set it for the superclass as well. Additionally, class data is usually The Wrong Thing To Do in a strongly OO program since it makes testing a lot harder - consider carefully whether you'd be better off with an object that's passed around instead. =head2 L This is a role that provides a number of methods useful for creating a daemon, including methods for starting and stopping, managing a PID file, and signal handling. =head2 L If you find yourself wanting a role that customizes itself for each consumer, this is the tool for you. With this module, you can create a role that accepts parameters and generates attributes, methods, etc. on a customized basis for each consumer. =head2 L This is a small wrapper that ties together a Moose class with C, and gives you an C sugar function to declare event handlers. =head2 L Automatically names all accessors I-style, "get_size" and "set_size". =head2 L Automatically names all accessors with an explicit set and implicit get, "size" and "set_size". =head2 L MooseX::NonMoose allows for easily subclassing non-Moose classes with Moose, taking care of the annoying details connected with doing this, such as setting up proper inheritance from Moose::Object and installing (and inlining, at make_immutable time) a constructor that makes sure things like BUILD methods are called. =head1 AUTHOR Moose is maintained by the Moose Cabal, along with the help of many contributors. See L and L for details. =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2013 by Infinity Interactive, Inc.. This is free software; you can redistribute it and/or modify it under the same terms as the Perl 5 programming language system itself. =cut Attribute.pm100644000767000024 14212112200352344 17414 0ustar00etherstaff000000000000Moose-2.1005/lib/Moose/Meta package Moose::Meta::Attribute; BEGIN { $Moose::Meta::Attribute::AUTHORITY = 'cpan:STEVAN'; } { $Moose::Meta::Attribute::VERSION = '2.1005'; } use strict; use warnings; use B (); use Class::Load qw(is_class_loaded load_class); use Scalar::Util 'blessed', 'weaken'; use List::MoreUtils 'any'; use Try::Tiny; use overload (); use Moose::Deprecated; use Moose::Meta::Method::Accessor; use Moose::Meta::Method::Delegation; use Moose::Util (); use Moose::Util::TypeConstraints (); use Class::MOP::MiniTrait; use base 'Class::MOP::Attribute', 'Moose::Meta::Mixin::AttributeCore'; Class::MOP::MiniTrait::apply(__PACKAGE__, 'Moose::Meta::Object::Trait'); __PACKAGE__->meta->add_attribute('traits' => ( reader => 'applied_traits', predicate => 'has_applied_traits', Class::MOP::_definition_context(), )); # we need to have a ->does method in here to # more easily support traits, and the introspection # of those traits. We extend the does check to look # for metatrait aliases. sub does { my ($self, $role_name) = @_; my $name = try { Moose::Util::resolve_metatrait_alias(Attribute => $role_name) }; return 0 if !defined($name); # failed to load class return $self->Moose::Object::does($name); } sub _error_thrower { my $self = shift; require Moose::Meta::Class; ( ref $self && $self->associated_class ) || "Moose::Meta::Class"; } sub throw_error { my $self = shift; my $inv = $self->_error_thrower; unshift @_, "message" if @_ % 2 == 1; unshift @_, attr => $self if ref $self; unshift @_, $inv; my $handler = $inv->can("throw_error"); # to avoid incrementing depth by 1 goto $handler; } sub _inline_throw_error { my ( $self, $msg, $args ) = @_; my $inv = $self->_error_thrower; # XXX ugh $inv = 'Moose::Meta::Class' unless $inv->can('_inline_throw_error'); # XXX ugh ugh UGH my $class = $self->associated_class; if ($class) { my $class_name = B::perlstring($class->name); my $attr_name = B::perlstring($self->name); $args = 'attr => Class::MOP::class_of(' . $class_name . ')' . '->find_attribute_by_name(' . $attr_name . '), ' . (defined $args ? $args : ''); } return $inv->_inline_throw_error($msg, $args) } sub new { my ($class, $name, %options) = @_; $class->_process_options($name, \%options) unless $options{__hack_no_process_options}; # used from clone()... YECHKKK FIXME ICKY YUCK GROSS delete $options{__hack_no_process_options}; my %attrs = ( map { $_ => 1 } grep { defined } map { $_->init_arg() } $class->meta()->get_all_attributes() ); my @bad = sort grep { ! $attrs{$_} } keys %options; if (@bad) { my $s = @bad > 1 ? 's' : ''; my $list = join "', '", @bad; my $package = $options{definition_context}{package}; my $context = $options{definition_context}{context} || 'attribute constructor'; my $type = $options{definition_context}{type} || 'class'; my $location = ''; if (defined($package)) { $location = " in "; $location .= "$type " if $type; $location .= $package; } Carp::cluck "Found unknown argument$s '$list' in the $context for '$name'$location"; } return $class->SUPER::new($name, %options); } sub interpolate_class_and_new { my ($class, $name, %args) = @_; my ( $new_class, @traits ) = $class->interpolate_class(\%args); $new_class->new($name, %args, ( scalar(@traits) ? ( traits => \@traits ) : () ) ); } sub interpolate_class { my ($class, $options) = @_; $class = ref($class) || $class; if ( my $metaclass_name = delete $options->{metaclass} ) { my $new_class = Moose::Util::resolve_metaclass_alias( Attribute => $metaclass_name ); if ( $class ne $new_class ) { if ( $new_class->can("interpolate_class") ) { return $new_class->interpolate_class($options); } else { $class = $new_class; } } } my @traits; if (my $traits = $options->{traits}) { my $i = 0; my $has_foreign_options = 0; while ($i < @$traits) { my $trait = $traits->[$i++]; next if ref($trait); # options to a trait we discarded $trait = Moose::Util::resolve_metatrait_alias(Attribute => $trait) || $trait; next if $class->does($trait); push @traits, $trait; # are there options? if ($traits->[$i] && ref($traits->[$i])) { $has_foreign_options = 1 if any { $_ ne '-alias' && $_ ne '-excludes' } keys %{ $traits->[$i] }; push @traits, $traits->[$i++]; } } if (@traits) { my %options = ( superclasses => [ $class ], roles => [ @traits ], ); if ($has_foreign_options) { $options{weaken} = 0; } else { $options{cache} = 1; } my $anon_class = Moose::Meta::Class->create_anon_class(%options); $class = $anon_class->name; } } return ( wantarray ? ( $class, @traits ) : $class ); } # ... # method-generating options shouldn't be overridden sub illegal_options_for_inheritance { qw(reader writer accessor clearer predicate) } # NOTE/TODO # This method *must* be able to handle # Class::MOP::Attribute instances as # well. Yes, I know that is wrong, but # apparently we didn't realize it was # doing that and now we have some code # which is dependent on it. The real # solution of course is to push this # feature back up into Class::MOP::Attribute # but I not right now, I am too lazy. # However if you are reading this and # looking for something to do,.. please # be my guest. # - stevan sub clone_and_inherit_options { my ($self, %options) = @_; # NOTE: # we may want to extends a Class::MOP::Attribute # in which case we need to be able to use the # core set of legal options that have always # been here. But we allows Moose::Meta::Attribute # instances to changes them. # - SL my @illegal_options = $self->can('illegal_options_for_inheritance') ? $self->illegal_options_for_inheritance : (); my @found_illegal_options = grep { exists $options{$_} && exists $self->{$_} ? $_ : undef } @illegal_options; (scalar @found_illegal_options == 0) || $self->throw_error("Illegal inherited options => (" . (join ', ' => @found_illegal_options) . ")", data => \%options); $self->_process_isa_option( $self->name, \%options ); $self->_process_does_option( $self->name, \%options ); # NOTE: # this doesn't apply to Class::MOP::Attributes, # so we can ignore it for them. # - SL if ($self->can('interpolate_class')) { ( $options{metaclass}, my @traits ) = $self->interpolate_class(\%options); my %seen; my @all_traits = grep { $seen{$_}++ } @{ $self->applied_traits || [] }, @traits; $options{traits} = \@all_traits if @all_traits; } # This method can be called on a CMOP::Attribute object, so we need to # make sure we can call this method. $self->_process_lazy_build_option( $self->name, \%options ) if $self->can('_process_lazy_build_option'); $self->clone(%options); } sub clone { my ( $self, %params ) = @_; my $class = delete $params{metaclass} || ref $self; my ( @init, @non_init ); foreach my $attr ( grep { $_->has_value($self) } Class::MOP::class_of($self)->get_all_attributes ) { push @{ $attr->has_init_arg ? \@init : \@non_init }, $attr; } my %new_params = ( ( map { $_->init_arg => $_->get_value($self) } @init ), %params ); my $name = delete $new_params{name}; my $clone = $class->new($name, %new_params, __hack_no_process_options => 1 ); foreach my $attr ( @non_init ) { $attr->set_value($clone, $attr->get_value($self)); } return $clone; } sub _process_options { my ( $class, $name, $options ) = @_; $class->_process_is_option( $name, $options ); $class->_process_isa_option( $name, $options ); $class->_process_does_option( $name, $options ); $class->_process_coerce_option( $name, $options ); $class->_process_trigger_option( $name, $options ); $class->_process_auto_deref_option( $name, $options ); $class->_process_lazy_build_option( $name, $options ); $class->_process_lazy_option( $name, $options ); $class->_process_required_option( $name, $options ); } sub _process_is_option { my ( $class, $name, $options ) = @_; return unless $options->{is}; ### ------------------------- ## is => ro, writer => _foo # turns into (reader => foo, writer => _foo) as before ## is => rw, writer => _foo # turns into (reader => foo, writer => _foo) ## is => rw, accessor => _foo # turns into (accessor => _foo) ## is => ro, accessor => _foo # error, accesor is rw ### ------------------------- if ( $options->{is} eq 'ro' ) { $class->throw_error( "Cannot define an accessor name on a read-only attribute, accessors are read/write", data => $options ) if exists $options->{accessor}; $options->{reader} ||= $name; } elsif ( $options->{is} eq 'rw' ) { if ( $options->{writer} ) { $options->{reader} ||= $name; } else { $options->{accessor} ||= $name; } } elsif ( $options->{is} eq 'bare' ) { return; # do nothing, but don't complain (later) about missing methods } else { $class->throw_error( "I do not understand this option (is => " . $options->{is} . ") on attribute ($name)", data => $options->{is} ); } } sub _process_isa_option { my ( $class, $name, $options ) = @_; return unless exists $options->{isa}; if ( exists $options->{does} ) { if ( try { $options->{isa}->can('does') } ) { ( $options->{isa}->does( $options->{does} ) ) || $class->throw_error( "Cannot have an isa option and a does option if the isa does not do the does on attribute ($name)", data => $options ); } else { $class->throw_error( "Cannot have an isa option which cannot ->does() on attribute ($name)", data => $options ); } } # allow for anon-subtypes here ... # # Checking for Specio explicitly is completely revolting. At some point # this needs to be refactored so that Moose core defines a standard type # API that all types must implement. Unfortunately, the current core API # is _not_ the right API, so we probably need to A) come up with the new # API (Specio is a good start); B) refactor the core types to implement # that API; C) do duck type checking on type objects. if ( blessed( $options->{isa} ) && $options->{isa}->isa('Moose::Meta::TypeConstraint') ) { $options->{type_constraint} = $options->{isa}; } elsif ( blessed( $options->{isa} ) && Moose::Util::does_role( $options->{isa}, 'Specio::Constraint::Role::Interface' ) ) { $options->{type_constraint} = $options->{isa}; } else { $options->{type_constraint} = Moose::Util::TypeConstraints::find_or_create_isa_type_constraint( $options->{isa}, { package_defined_in => $options->{definition_context}->{package} } ); } } sub _process_does_option { my ( $class, $name, $options ) = @_; return unless exists $options->{does} && ! exists $options->{isa}; # allow for anon-subtypes here ... if ( blessed( $options->{does} ) && $options->{does}->isa('Moose::Meta::TypeConstraint') ) { $options->{type_constraint} = $options->{does}; } else { $options->{type_constraint} = Moose::Util::TypeConstraints::find_or_create_does_type_constraint( $options->{does}, { package_defined_in => $options->{definition_context}->{package} } ); } } sub _process_coerce_option { my ( $class, $name, $options ) = @_; return unless $options->{coerce}; ( exists $options->{type_constraint} ) || $class->throw_error( "You cannot have coercion without specifying a type constraint on attribute ($name)", data => $options ); $class->throw_error( "You cannot have a weak reference to a coerced value on attribute ($name)", data => $options ) if $options->{weak_ref}; unless ( $options->{type_constraint}->has_coercion ) { my $type = $options->{type_constraint}->name; Moose::Deprecated::deprecated( feature => 'coerce without coercion', message => "You cannot coerce an attribute ($name) unless its type ($type) has a coercion" ); } } sub _process_trigger_option { my ( $class, $name, $options ) = @_; return unless exists $options->{trigger}; ( 'CODE' eq ref $options->{trigger} ) || $class->throw_error("Trigger must be a CODE ref on attribute ($name)", data => $options->{trigger}); } sub _process_auto_deref_option { my ( $class, $name, $options ) = @_; return unless $options->{auto_deref}; ( exists $options->{type_constraint} ) || $class->throw_error( "You cannot auto-dereference without specifying a type constraint on attribute ($name)", data => $options ); ( $options->{type_constraint}->is_a_type_of('ArrayRef') || $options->{type_constraint}->is_a_type_of('HashRef') ) || $class->throw_error( "You cannot auto-dereference anything other than a ArrayRef or HashRef on attribute ($name)", data => $options ); } sub _process_lazy_build_option { my ( $class, $name, $options ) = @_; return unless $options->{lazy_build}; $class->throw_error( "You can not use lazy_build and default for the same attribute ($name)", data => $options ) if exists $options->{default}; $options->{lazy} = 1; $options->{builder} ||= "_build_${name}"; if ( $name =~ /^_/ ) { $options->{clearer} ||= "_clear${name}"; $options->{predicate} ||= "_has${name}"; } else { $options->{clearer} ||= "clear_${name}"; $options->{predicate} ||= "has_${name}"; } } sub _process_lazy_option { my ( $class, $name, $options ) = @_; return unless $options->{lazy}; ( exists $options->{default} || defined $options->{builder} ) || $class->throw_error( "You cannot have a lazy attribute ($name) without specifying a default value for it", data => $options ); } sub _process_required_option { my ( $class, $name, $options ) = @_; if ( $options->{required} && !( ( !exists $options->{init_arg} || defined $options->{init_arg} ) || exists $options->{default} || defined $options->{builder} ) ) { $class->throw_error( "You cannot have a required attribute ($name) without a default, builder, or an init_arg", data => $options ); } } sub initialize_instance_slot { my ($self, $meta_instance, $instance, $params) = @_; my $init_arg = $self->init_arg(); # try to fetch the init arg from the %params ... my $val; my $value_is_set; if ( defined($init_arg) and exists $params->{$init_arg}) { $val = $params->{$init_arg}; $value_is_set = 1; } else { # skip it if it's lazy return if $self->is_lazy; # and die if it's required and doesn't have a default value $self->throw_error("Attribute (" . $self->name . ") is required", object => $instance, data => $params) if $self->is_required && !$self->has_default && !$self->has_builder; # if nothing was in the %params, we can use the # attribute's default value (if it has one) if ($self->has_default) { $val = $self->default($instance); $value_is_set = 1; } elsif ($self->has_builder) { $val = $self->_call_builder($instance); $value_is_set = 1; } } return unless $value_is_set; $val = $self->_coerce_and_verify( $val, $instance ); $self->set_initial_value($instance, $val); if ( ref $val && $self->is_weak_ref ) { $self->_weaken_value($instance); } } sub _call_builder { my ( $self, $instance ) = @_; my $builder = $self->builder(); return $instance->$builder() if $instance->can( $self->builder ); $self->throw_error( blessed($instance) . " does not support builder method '" . $self->builder . "' for attribute '" . $self->name . "'", object => $instance, ); } ## Slot management sub _make_initializer_writer_callback { my $self = shift; my ($meta_instance, $instance, $slot_name) = @_; my $old_callback = $self->SUPER::_make_initializer_writer_callback(@_); return sub { $old_callback->($self->_coerce_and_verify($_[0], $instance)); }; } sub set_value { my ($self, $instance, @args) = @_; my $value = $args[0]; my $attr_name = quotemeta($self->name); if ($self->is_required and not @args) { $self->throw_error("Attribute ($attr_name) is required", object => $instance); } $value = $self->_coerce_and_verify( $value, $instance ); my @old; if ( $self->has_trigger && $self->has_value($instance) ) { @old = $self->get_value($instance, 'for trigger'); } $self->SUPER::set_value($instance, $value); if ( ref $value && $self->is_weak_ref ) { $self->_weaken_value($instance); } if ($self->has_trigger) { $self->trigger->($instance, $value, @old); } } sub _inline_set_value { my $self = shift; my ($instance, $value, $tc, $coercion, $message, $for_constructor) = @_; my $old = '@old'; my $copy = '$val'; $tc ||= '$type_constraint'; $coercion ||= '$type_coercion'; $message ||= '$type_message'; my @code; if ($self->_writer_value_needs_copy) { push @code, $self->_inline_copy_value($value, $copy); $value = $copy; } # constructors already handle required checks push @code, $self->_inline_check_required unless $for_constructor; push @code, $self->_inline_tc_code($value, $tc, $coercion, $message); # constructors do triggers all at once at the end push @code, $self->_inline_get_old_value_for_trigger($instance, $old) unless $for_constructor; push @code, ( $self->SUPER::_inline_set_value($instance, $value), $self->_inline_weaken_value($instance, $value), ); # constructors do triggers all at once at the end push @code, $self->_inline_trigger($instance, $value, $old) unless $for_constructor; return @code; } sub _writer_value_needs_copy { my $self = shift; return $self->should_coerce; } sub _inline_copy_value { my $self = shift; my ($value, $copy) = @_; return 'my ' . $copy . ' = ' . $value . ';' } sub _inline_check_required { my $self = shift; return unless $self->is_required; my $attr_name = quotemeta($self->name); return ( 'if (@_ < 2) {', $self->_inline_throw_error( '"Attribute (' . $attr_name . ') is required"' ) . ';', '}', ); } sub _inline_tc_code { my $self = shift; my ($value, $tc, $coercion, $message, $is_lazy) = @_; return ( $self->_inline_check_coercion( $value, $tc, $coercion, $is_lazy, ), $self->_inline_check_constraint( $value, $tc, $message, $is_lazy, ), ); } sub _inline_check_coercion { my $self = shift; my ($value, $tc, $coercion) = @_; return unless $self->should_coerce && $self->type_constraint->has_coercion; if ( $self->type_constraint->can_be_inlined ) { return ( 'if (! (' . $self->type_constraint->_inline_check($value) . ')) {', $value . ' = ' . $coercion . '->(' . $value . ');', '}', ); } else { return ( 'if (!' . $tc . '->(' . $value . ')) {', $value . ' = ' . $coercion . '->(' . $value . ');', '}', ); } } sub _inline_check_constraint { my $self = shift; my ($value, $tc, $message) = @_; return unless $self->has_type_constraint; my $attr_name = quotemeta($self->name); if ( $self->type_constraint->can_be_inlined ) { return ( 'if (! (' . $self->type_constraint->_inline_check($value) . ')) {', $self->_inline_throw_error( '"Attribute (' . $attr_name . ') does not pass the type ' . 'constraint because: " . ' . 'do { local $_ = ' . $value . '; ' . $message . '->(' . $value . ')' . '}', 'data => ' . $value ) . ';', '}', ); } else { return ( 'if (!' . $tc . '->(' . $value . ')) {', $self->_inline_throw_error( '"Attribute (' . $attr_name . ') does not pass the type ' . 'constraint because: " . ' . 'do { local $_ = ' . $value . '; ' . $message . '->(' . $value . ')' . '}', 'data => ' . $value ) . ';', '}', ); } } sub _inline_get_old_value_for_trigger { my $self = shift; my ($instance, $old) = @_; return unless $self->has_trigger; return ( 'my ' . $old . ' = ' . $self->_inline_instance_has($instance), '? ' . $self->_inline_instance_get($instance), ': ();', ); } sub _inline_weaken_value { my $self = shift; my ($instance, $value) = @_; return unless $self->is_weak_ref; my $mi = $self->associated_class->get_meta_instance; return ( $mi->inline_weaken_slot_value($instance, $self->name), 'if ref ' . $value . ';', ); } sub _inline_trigger { my $self = shift; my ($instance, $value, $old) = @_; return unless $self->has_trigger; return '$trigger->(' . $instance . ', ' . $value . ', ' . $old . ');'; } sub _eval_environment { my $self = shift; my $env = { }; $env->{'$trigger'} = \($self->trigger) if $self->has_trigger; $env->{'$attr_default'} = \($self->default) if $self->has_default; if ($self->has_type_constraint) { my $tc_obj = $self->type_constraint; $env->{'$type_constraint'} = \( $tc_obj->_compiled_type_constraint ) unless $tc_obj->can_be_inlined; # these two could probably get inlined versions too $env->{'$type_coercion'} = \( $tc_obj->coercion->_compiled_type_coercion ) if $tc_obj->has_coercion; $env->{'$type_message'} = \( $tc_obj->has_message ? $tc_obj->message : $tc_obj->_default_message ); $env = { %$env, %{ $tc_obj->inline_environment } }; } # XXX ugh, fix these $env->{'$attr'} = \$self if $self->has_initializer && $self->is_lazy; # pretty sure this is only going to be closed over if you use a custom # error class at this point, but we should still get rid of this # at some point $env->{'$meta'} = \($self->associated_class); return $env; } sub _weaken_value { my ( $self, $instance ) = @_; my $meta_instance = Class::MOP::Class->initialize( blessed($instance) ) ->get_meta_instance; $meta_instance->weaken_slot_value( $instance, $self->name ); } sub get_value { my ($self, $instance, $for_trigger) = @_; if ($self->is_lazy) { unless ($self->has_value($instance)) { my $value; if ($self->has_default) { $value = $self->default($instance); } elsif ( $self->has_builder ) { $value = $self->_call_builder($instance); } $value = $self->_coerce_and_verify( $value, $instance ); $self->set_initial_value($instance, $value); if ( ref $value && $self->is_weak_ref ) { $self->_weaken_value($instance); } } } if ( $self->should_auto_deref && ! $for_trigger ) { my $type_constraint = $self->type_constraint; if ($type_constraint->is_a_type_of('ArrayRef')) { my $rv = $self->SUPER::get_value($instance); return unless defined $rv; return wantarray ? @{ $rv } : $rv; } elsif ($type_constraint->is_a_type_of('HashRef')) { my $rv = $self->SUPER::get_value($instance); return unless defined $rv; return wantarray ? %{ $rv } : $rv; } else { $self->throw_error("Can not auto de-reference the type constraint '" . $type_constraint->name . "'", object => $instance, type_constraint => $type_constraint); } } else { return $self->SUPER::get_value($instance); } } sub _inline_get_value { my $self = shift; my ($instance, $tc, $coercion, $message) = @_; my $slot_access = $self->_inline_instance_get($instance); $tc ||= '$type_constraint'; $coercion ||= '$type_coercion'; $message ||= '$type_message'; return ( $self->_inline_check_lazy($instance, $tc, $coercion, $message), $self->_inline_return_auto_deref($slot_access), ); } sub _inline_check_lazy { my $self = shift; my ($instance, $tc, $coercion, $message) = @_; return unless $self->is_lazy; my $slot_exists = $self->_inline_instance_has($instance); return ( 'if (!' . $slot_exists . ') {', $self->_inline_init_from_default($instance, '$default', $tc, $coercion, $message, 'lazy'), '}', ); } sub _inline_init_from_default { my $self = shift; my ($instance, $default, $tc, $coercion, $message, $for_lazy) = @_; if (!($self->has_default || $self->has_builder)) { $self->throw_error( 'You cannot have a lazy attribute ' . '(' . $self->name . ') ' . 'without specifying a default value for it', attr => $self, ); } return ( $self->_inline_generate_default($instance, $default), # intentionally not using _inline_tc_code, since that can be overridden # to do things like possibly only do member tc checks, which isn't # appropriate for checking the result of a default $self->has_type_constraint ? ($self->_inline_check_coercion($default, $tc, $coercion, $for_lazy), $self->_inline_check_constraint($default, $tc, $message, $for_lazy)) : (), $self->_inline_init_slot($instance, $default), $self->_inline_weaken_value($instance, $default), ); } sub _inline_generate_default { my $self = shift; my ($instance, $default) = @_; if ($self->has_default) { my $source = 'my ' . $default . ' = $attr_default'; $source .= '->(' . $instance . ')' if $self->is_default_a_coderef; return $source . ';'; } elsif ($self->has_builder) { my $builder = B::perlstring($self->builder); my $builder_str = quotemeta($self->builder); my $attr_name_str = quotemeta($self->name); return ( 'my ' . $default . ';', 'if (my $builder = ' . $instance . '->can(' . $builder . ')) {', $default . ' = ' . $instance . '->$builder;', '}', 'else {', 'my $class = ref(' . $instance . ') || ' . $instance . ';', $self->_inline_throw_error( '"$class does not support builder method ' . '\'' . $builder_str . '\' for attribute ' . '\'' . $attr_name_str . '\'"' ) . ';', '}', ); } else { $self->throw_error( "Can't generate a default for " . $self->name . " since no default or builder was specified" ); } } sub _inline_init_slot { my $self = shift; my ($inv, $value) = @_; if ($self->has_initializer) { return '$attr->set_initial_value(' . $inv . ', ' . $value . ');'; } else { return $self->_inline_instance_set($inv, $value) . ';'; } } sub _inline_return_auto_deref { my $self = shift; return 'return ' . $self->_auto_deref(@_) . ';'; } sub _auto_deref { my $self = shift; my ($ref_value) = @_; return $ref_value unless $self->should_auto_deref; my $type_constraint = $self->type_constraint; my $sigil; if ($type_constraint->is_a_type_of('ArrayRef')) { $sigil = '@'; } elsif ($type_constraint->is_a_type_of('HashRef')) { $sigil = '%'; } else { $self->throw_error( 'Can not auto de-reference the type constraint \'' . $type_constraint->name . '\'', type_constraint => $type_constraint, ); } return 'wantarray ' . '? ' . $sigil . '{ (' . $ref_value . ') || return } ' . ': (' . $ref_value . ')'; } ## installing accessors sub accessor_metaclass { 'Moose::Meta::Method::Accessor' } sub install_accessors { my $self = shift; $self->SUPER::install_accessors(@_); $self->install_delegation if $self->has_handles; return; } sub _check_associated_methods { my $self = shift; unless ( @{ $self->associated_methods } || ($self->_is_metadata || '') eq 'bare' ) { Carp::cluck( 'Attribute (' . $self->name . ') of class ' . $self->associated_class->name . ' has no associated methods' . ' (did you mean to provide an "is" argument?)' . "\n" ) } } sub _process_accessors { my $self = shift; my ($type, $accessor, $generate_as_inline_methods) = @_; $accessor = ( keys %$accessor )[0] if ( ref($accessor) || '' ) eq 'HASH'; my $method = $self->associated_class->get_method($accessor); if ( $method && $method->isa('Class::MOP::Method::Accessor') && $method->associated_attribute->name ne $self->name ) { my $other_attr_name = $method->associated_attribute->name; my $name = $self->name; Carp::cluck( "You are overwriting an accessor ($accessor) for the $other_attr_name attribute" . " with a new accessor method for the $name attribute" ); } if ( $method && !$method->is_stub && !$method->isa('Class::MOP::Method::Accessor') && ( !$self->definition_context || $method->package_name eq $self->definition_context->{package} ) ) { Carp::cluck( "You are overwriting a locally defined method ($accessor) with " . "an accessor" ); } if ( !$self->associated_class->has_method($accessor) && $self->associated_class->has_package_symbol( '&' . $accessor ) ) { Carp::cluck( "You are overwriting a locally defined function ($accessor) with " . "an accessor" ); } $self->SUPER::_process_accessors(@_); } sub remove_accessors { my $self = shift; $self->SUPER::remove_accessors(@_); $self->remove_delegation if $self->has_handles; return; } sub install_delegation { my $self = shift; # NOTE: # Here we canonicalize the 'handles' option # this will sort out any details and always # return an hash of methods which we want # to delagate to, see that method for details my %handles = $self->_canonicalize_handles; # install the delegation ... my $associated_class = $self->associated_class; foreach my $handle (sort keys %handles) { my $method_to_call = $handles{$handle}; my $class_name = $associated_class->name; my $name = "${class_name}::${handle}"; if ( my $method = $associated_class->get_method($handle) ) { $self->throw_error( "You cannot overwrite a locally defined method ($handle) with a delegation", method_name => $handle ) unless $method->is_stub; } # NOTE: # handles is not allowed to delegate # any of these methods, as they will # override the ones in your class, which # is almost certainly not what you want. # FIXME warn when $handle was explicitly specified, but not if the source is a regex or something #cluck("Not delegating method '$handle' because it is a core method") and next if $class_name->isa("Moose::Object") and $handle =~ /^BUILD|DEMOLISH$/ || Moose::Object->can($handle); my $method = $self->_make_delegation_method($handle, $method_to_call); $self->associated_class->add_method($method->name, $method); $self->associate_method($method); } } sub remove_delegation { my $self = shift; my %handles = $self->_canonicalize_handles; my $associated_class = $self->associated_class; foreach my $handle (keys %handles) { next unless any { $handle eq $_ } map { $_->name } @{ $self->associated_methods }; $self->associated_class->remove_method($handle); } } # private methods to help delegation ... sub _canonicalize_handles { my $self = shift; my $handles = $self->handles; if (my $handle_type = ref($handles)) { if ($handle_type eq 'HASH') { return %{$handles}; } elsif ($handle_type eq 'ARRAY') { return map { $_ => $_ } @{$handles}; } elsif ($handle_type eq 'Regexp') { ($self->has_type_constraint) || $self->throw_error("Cannot delegate methods based on a Regexp without a type constraint (isa)", data => $handles); return map { ($_ => $_) } grep { /$handles/ } $self->_get_delegate_method_list; } elsif ($handle_type eq 'CODE') { return $handles->($self, $self->_find_delegate_metaclass); } elsif (blessed($handles) && $handles->isa('Moose::Meta::TypeConstraint::DuckType')) { return map { $_ => $_ } @{ $handles->methods }; } elsif (blessed($handles) && $handles->isa('Moose::Meta::TypeConstraint::Role')) { $handles = $handles->role; } else { $self->throw_error("Unable to canonicalize the 'handles' option with $handles", data => $handles); } } load_class($handles); my $role_meta = Class::MOP::class_of($handles); (blessed $role_meta && $role_meta->isa('Moose::Meta::Role')) || $self->throw_error("Unable to canonicalize the 'handles' option with $handles because its metaclass is not a Moose::Meta::Role", data => $handles); return map { $_ => $_ } map { $_->name } grep { !$_->isa('Class::MOP::Method::Meta') } ( $role_meta->_get_local_methods, $role_meta->get_required_method_list, ); } sub _get_delegate_method_list { my $self = shift; my $meta = $self->_find_delegate_metaclass; if ($meta->isa('Class::MOP::Class')) { return map { $_->name } # NOTE: !never! delegate &meta grep { $_->package_name ne 'Moose::Object' && !$_->isa('Class::MOP::Method::Meta') } $meta->get_all_methods; } elsif ($meta->isa('Moose::Meta::Role')) { return $meta->get_method_list; } else { $self->throw_error("Unable to recognize the delegate metaclass '$meta'", data => $meta); } } sub _find_delegate_metaclass { my $self = shift; if (my $class = $self->_isa_metadata) { unless ( is_class_loaded($class) ) { $self->throw_error( sprintf( 'The %s attribute is trying to delegate to a class which has not been loaded - %s', $self->name, $class ) ); } # we might be dealing with a non-Moose class, # and need to make our own metaclass. if there's # already a metaclass, it will be returned return Class::MOP::Class->initialize($class); } elsif (my $role = $self->_does_metadata) { unless ( is_class_loaded($class) ) { $self->throw_error( sprintf( 'The %s attribute is trying to delegate to a role which has not been loaded - %s', $self->name, $role ) ); } return Class::MOP::class_of($role); } else { $self->throw_error("Cannot find delegate metaclass for attribute " . $self->name); } } sub delegation_metaclass { 'Moose::Meta::Method::Delegation' } sub _make_delegation_method { my ( $self, $handle_name, $method_to_call ) = @_; my @curried_arguments; ($method_to_call, @curried_arguments) = @$method_to_call if 'ARRAY' eq ref($method_to_call); return $self->delegation_metaclass->new( name => $handle_name, package_name => $self->associated_class->name, attribute => $self, delegate_to_method => $method_to_call, curried_arguments => \@curried_arguments, ); } sub _coerce_and_verify { my $self = shift; my $val = shift; my $instance = shift; return $val unless $self->has_type_constraint; $val = $self->type_constraint->coerce($val) if $self->should_coerce && $self->type_constraint->has_coercion; $self->verify_against_type_constraint($val, instance => $instance); return $val; } sub verify_against_type_constraint { my $self = shift; my $val = shift; return 1 if !$self->has_type_constraint; my $type_constraint = $self->type_constraint; $type_constraint->check($val) || $self->throw_error("Attribute (" . $self->name . ") does not pass the type constraint because: " . $type_constraint->get_message($val), data => $val, @_); } package Moose::Meta::Attribute::Custom::Moose; BEGIN { $Moose::Meta::Attribute::Custom::Moose::AUTHORITY = 'cpan:STEVAN'; } { $Moose::Meta::Attribute::Custom::Moose::VERSION = '2.1005'; } sub register_implementation { 'Moose::Meta::Attribute' } 1; # ABSTRACT: The Moose attribute metaclass __END__ =pod =head1 NAME Moose::Meta::Attribute - The Moose attribute metaclass =head1 VERSION version 2.1005 =head1 DESCRIPTION This class is a subclass of L that provides additional Moose-specific functionality. To really understand this class, you will need to start with the L documentation. This class can be understood as a set of additional features on top of the basic feature provided by that parent class. =head1 INHERITANCE C is a subclass of L. =head1 METHODS Many of the documented below override methods in L and add Moose specific features. =head2 Creation =over 4 =item B<< Moose::Meta::Attribute->new($name, %options) >> This method overrides the L constructor. Many of the options below are described in more detail in the L document. It adds the following options to the constructor: =over 8 =item * is => 'ro', 'rw', 'bare' This provides a shorthand for specifying the C, C, or C names. If the attribute is read-only ('ro') then it will have a C method with the same attribute as the name. If it is read-write ('rw') then it will have an C method with the same name. If you provide an explicit C for a read-write attribute, then you will have a C with the same name as the attribute, and a C with the name you provided. Use 'bare' when you are deliberately not installing any methods (accessor, reader, etc.) associated with this attribute; otherwise, Moose will issue a deprecation warning when this attribute is added to a metaclass. =item * isa => $type This option accepts a type. The type can be a string, which should be a type name. If the type name is unknown, it is assumed to be a class name. This option can also accept a L object. If you I provide a C option, then your C option must be a class name, and that class must do the role specified with C. =item * does => $role This is short-hand for saying that the attribute's type must be an object which does the named role. =item * coerce => $bool This option is only valid for objects with a type constraint (C) that defined a coercion. If this is true, then coercions will be applied whenever this attribute is set. You can make both this and the C option true. =item * trigger => $sub This option accepts a subroutine reference, which will be called after the attribute is set. =item * required => $bool An attribute which is required must be provided to the constructor. An attribute which is required can also have a C or C, which will satisfy its required-ness. A required attribute must have a C, C or a non-C C =item * lazy => $bool A lazy attribute must have a C or C. When an attribute is lazy, the default value will not be calculated until the attribute is read. =item * weak_ref => $bool If this is true, the attribute's value will be stored as a weak reference. =item * auto_deref => $bool If this is true, then the reader will dereference the value when it is called. The attribute must have a type constraint which defines the attribute as an array or hash reference. =item * lazy_build => $bool Setting this to true makes the attribute lazy and provides a number of default methods. has 'size' => ( is => 'ro', lazy_build => 1, ); is equivalent to this: has 'size' => ( is => 'ro', lazy => 1, builder => '_build_size', clearer => 'clear_size', predicate => 'has_size', ); If your attribute name starts with an underscore (C<_>), then the clearer and predicate will as well: has '_size' => ( is => 'ro', lazy_build => 1, ); becomes: has '_size' => ( is => 'ro', lazy => 1, builder => '_build__size', clearer => '_clear_size', predicate => '_has_size', ); Note the doubled underscore in the builder name. Internally, Moose simply prepends the attribute name with "_build_" to come up with the builder name. =item * documentation An arbitrary string that can be retrieved later by calling C<< $attr->documentation >>. =back =item B<< $attr->clone(%options) >> This creates a new attribute based on attribute being cloned. You must supply a C option to provide a new name for the attribute. The C<%options> can only specify options handled by L. =back =head2 Value management =over 4 =item B<< $attr->initialize_instance_slot($meta_instance, $instance, $params) >> This method is used internally to initialize the attribute's slot in the object C<$instance>. This overrides the L method to handle lazy attributes, weak references, and type constraints. =item B =item B eval { $point->meta->get_attribute('x')->set_value($point, 'forty-two') }; if($@) { print "Oops: $@\n"; } I Before setting the value, a check is made on the type constraint of the attribute, if it has one, to see if the value passes it. If the value fails to pass, the set operation dies. Any coercion to convert values is done before checking the type constraint. To check a value against a type constraint before setting it, fetch the attribute instance using L, fetch the type_constraint from the attribute using L and call L. See L for an example. =back =head2 Attribute Accessor generation =over 4 =item B<< $attr->install_accessors >> This method overrides the parent to also install delegation methods. If, after installing all methods, the attribute object has no associated methods, it throws an error unless C<< is => 'bare' >> was passed to the attribute constructor. (Trying to add an attribute that has no associated methods is almost always an error.) =item B<< $attr->remove_accessors >> This method overrides the parent to also remove delegation methods. =item B<< $attr->inline_set($instance_var, $value_var) >> This method return a code snippet suitable for inlining the relevant operation. It expect strings containing variable names to be used in the inlining, like C<'$self'> or C<'$_[1]'>. =item B<< $attr->install_delegation >> This method adds its delegation methods to the attribute's associated class, if it has any to add. =item B<< $attr->remove_delegation >> This method remove its delegation methods from the attribute's associated class. =item B<< $attr->accessor_metaclass >> Returns the accessor metaclass name, which defaults to L. =item B<< $attr->delegation_metaclass >> Returns the delegation metaclass name, which defaults to L. =back =head2 Additional Moose features These methods are not found in the superclass. They support features provided by Moose. =over 4 =item B<< $attr->does($role) >> This indicates whether the I does the given role. The role can be given as a full class name, or as a resolvable trait name. Note that this checks the attribute itself, not its type constraint, so it is checking the attribute's metaclass and any traits applied to the attribute. =item B<< Moose::Meta::Class->interpolate_class_and_new($name, %options) >> This is an alternate constructor that handles the C and C options. Effectively, this method is a factory that finds or creates the appropriate class for the given C and/or C. Once it has the appropriate class, it will call C<< $class->new($name, %options) >> on that class. =item B<< $attr->clone_and_inherit_options(%options) >> This method supports the C feature. It does various bits of processing on the supplied C<%options> before ultimately calling the C method. One of its main tasks is to make sure that the C<%options> provided does not include the options returned by the C method. =item B<< $attr->illegal_options_for_inheritance >> This returns a blacklist of options that can not be overridden in a subclass's attribute definition. This exists to allow a custom metaclass to change or add to the list of options which can not be changed. =item B<< $attr->type_constraint >> Returns the L object for this attribute, if it has one. =item B<< $attr->has_type_constraint >> Returns true if this attribute has a type constraint. =item B<< $attr->verify_against_type_constraint($value) >> Given a value, this method returns true if the value is valid for the attribute's type constraint. If the value is not valid, it throws an error. =item B<< $attr->handles >> This returns the value of the C option passed to the constructor. =item B<< $attr->has_handles >> Returns true if this attribute performs delegation. =item B<< $attr->is_weak_ref >> Returns true if this attribute stores its value as a weak reference. =item B<< $attr->is_required >> Returns true if this attribute is required to have a value. =item B<< $attr->is_lazy >> Returns true if this attribute is lazy. =item B<< $attr->is_lazy_build >> Returns true if the C option was true when passed to the constructor. =item B<< $attr->should_coerce >> Returns true if the C option passed to the constructor was true. =item B<< $attr->should_auto_deref >> Returns true if the C option passed to the constructor was true. =item B<< $attr->trigger >> This is the subroutine reference that was in the C option passed to the constructor, if any. =item B<< $attr->has_trigger >> Returns true if this attribute has a trigger set. =item B<< $attr->documentation >> Returns the value that was in the C option passed to the constructor, if any. =item B<< $attr->has_documentation >> Returns true if this attribute has any documentation. =item B<< $attr->applied_traits >> This returns an array reference of all the traits which were applied to this attribute. If none were applied, this returns C. =item B<< $attr->has_applied_traits >> Returns true if this attribute has any traits applied. =back =head1 BUGS See L for details on reporting bugs. =head1 AUTHOR Moose is maintained by the Moose Cabal, along with the help of many contributors. See L and L for details. =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2013 by Infinity Interactive, Inc.. This is free software; you can redistribute it and/or modify it under the same terms as the Perl 5 programming language system itself. =cut DEMOLISH_eats_mini.t100644000767000024 254012200352344 17161 0ustar00etherstaff000000000000Moose-2.1005/t/bugs#!/usr/bin/perl use strict; use warnings; use Test::More; use Test::Fatal; { package Foo; use Moose; has 'bar' => ( is => 'ro', required => 1, ); # Defining this causes the FIRST call to Baz->new w/o param to fail, # if no call to ANY Moose::Object->new was done before. sub DEMOLISH { my ( $self ) = @_; # ... Moose (kinda) eats exceptions in DESTROY/DEMOLISH"; } } { my $obj = eval { Foo->new; }; like( $@, qr/is required/, "... Foo plain" ); is( $obj, undef, "... the object is undef" ); } { package Bar; sub new { die "Bar died"; } sub DESTROY { die "Vanilla Perl eats exceptions in DESTROY too"; } } { my $obj = eval { Bar->new; }; like( $@, qr/Bar died/, "... Bar plain" ); is( $obj, undef, "... the object is undef" ); } { package Baz; use Moose; sub DEMOLISH { $? = 0; } } { local $@ = 42; local $? = 84; { Baz->new; } is( $@, 42, '$@ is still 42 after object is demolished without dying' ); is( $?, 84, '$? is still 84 after object is demolished without dying' ); local $@ = 0; { Baz->new; } is( $@, 0, '$@ is still 0 after object is demolished without dying' ); Baz->meta->make_immutable, redo if Baz->meta->is_mutable } done_testing; Moose_Object_error.t100644000767000024 17612200352344 17471 0ustar00etherstaff000000000000Moose-2.1005/t/bugs#!/usr/bin/perl use strict; use warnings; use lib 't/lib', 'lib'; use Test::More; use_ok('MyMooseObject'); done_testing; anon_class_removal.t100644000767000024 135612200352344 17574 0ustar00etherstaff000000000000Moose-2.1005/t/cmop#!/usr/bin/env perl use strict; use warnings; use Test::More; use Class::MOP; { my $class; { my $meta = Class::MOP::Class->create_anon_class( methods => { foo => sub { 'FOO' }, }, ); $class = $meta->name; can_ok($class, 'foo'); is($class->foo, 'FOO'); } ok(!$class->can('foo')); } { my $class; { my $meta = Class::MOP::Class->create_anon_class( methods => { foo => sub { 'FOO' }, }, ); $class = $meta->name; can_ok($class, 'foo'); is($class->foo, 'FOO'); Class::MOP::remove_metaclass_by_name($class); } ok(!$class->can('foo')); } done_testing; self_introspection.t100644000767000024 3441012200352344 17655 0ustar00etherstaff000000000000Moose-2.1005/t/cmopuse strict; use warnings; use Test::More; use Test::Fatal; use Class::MOP; use Class::MOP::Class; use Class::MOP::Package; use Class::MOP::Module; { my $class = Class::MOP::Class->initialize('Foo'); is($class->meta, Class::MOP::Class->meta, '... instance and class both lead to the same meta'); } my $class_mop_class_meta = Class::MOP::Class->meta(); isa_ok($class_mop_class_meta, 'Class::MOP::Class'); my $class_mop_package_meta = Class::MOP::Package->meta(); isa_ok($class_mop_package_meta, 'Class::MOP::Package'); my $class_mop_module_meta = Class::MOP::Module->meta(); isa_ok($class_mop_module_meta, 'Class::MOP::Module'); my @class_mop_package_methods = qw( _new initialize reinitialize create create_anon is_anon _free_anon _anon_cache_key _anon_package_prefix name namespace add_package_symbol get_package_symbol has_package_symbol remove_package_symbol get_or_add_package_symbol list_all_package_symbols get_all_package_symbols remove_package_glob _package_stash DESTROY ); my @class_mop_module_methods = qw( _new _instantiate_module version authority identifier create _anon_cache_key _anon_package_prefix ); my @class_mop_class_methods = qw( _new is_pristine initialize reinitialize create create_anon_class is_anon_class _anon_cache_key _anon_package_prefix instance_metaclass get_meta_instance _inline_create_instance _inline_rebless_instance _inline_get_mop_slot _inline_set_mop_slot _inline_clear_mop_slot _create_meta_instance new_object clone_object _inline_new_object _inline_default_value _inline_preserve_weak_metaclasses _inline_slot_initializer _inline_extra_init _inline_fallback_constructor _inline_generate_instance _inline_params _inline_slot_initializers _inline_init_attr_from_constructor _inline_init_attr_from_default _generate_fallback_constructor _eval_environment _construct_instance _construct_class_instance _clone_instance rebless_instance rebless_instance_back rebless_instance_away _force_rebless_instance _fixup_attributes_after_rebless _check_metaclass_compatibility _check_class_metaclass_compatibility _check_single_metaclass_compatibility _class_metaclass_is_compatible _single_metaclass_is_compatible _fix_metaclass_incompatibility _fix_class_metaclass_incompatibility _fix_single_metaclass_incompatibility _base_metaclasses _can_fix_metaclass_incompatibility _class_metaclass_can_be_made_compatible _single_metaclass_can_be_made_compatible _remove_generated_metaobjects _restore_metaobjects_from add_meta_instance_dependencies remove_meta_instance_dependencies update_meta_instance_dependencies add_dependent_meta_instance remove_dependent_meta_instance invalidate_meta_instances invalidate_meta_instance superclasses subclasses direct_subclasses class_precedence_list linearized_isa _method_lookup_order _superclasses_updated _superclass_metas get_all_method_names get_all_methods find_method_by_name find_all_methods_by_name find_next_method_by_name add_before_method_modifier add_after_method_modifier add_around_method_modifier _attach_attribute _post_add_attribute remove_attribute find_attribute_by_name get_all_attributes is_mutable is_immutable make_mutable make_immutable _initialize_immutable _install_inlined_code _inlined_methods _add_inlined_method _inline_accessors _inline_constructor _inline_destructor _immutable_options _real_ref_name _rebless_as_immutable _rebless_as_mutable _remove_inlined_code _immutable_metaclass immutable_trait immutable_options constructor_name constructor_class destructor_class ); # check the class ... is_deeply([ sort $class_mop_class_meta->get_method_list ], [ sort @class_mop_class_methods ], '... got the correct method list for class'); foreach my $method_name (sort @class_mop_class_methods) { ok($class_mop_class_meta->has_method($method_name), '... Class::MOP::Class->has_method(' . $method_name . ')'); { no strict 'refs'; is($class_mop_class_meta->get_method($method_name)->body, \&{'Class::MOP::Class::' . $method_name}, '... Class::MOP::Class->get_method(' . $method_name . ') == &Class::MOP::Class::' . $method_name); } } ## check the package .... is_deeply([ sort $class_mop_package_meta->get_method_list ], [ sort @class_mop_package_methods ], '... got the correct method list for package'); foreach my $method_name (sort @class_mop_package_methods) { ok($class_mop_package_meta->has_method($method_name), '... Class::MOP::Package->has_method(' . $method_name . ')'); { no strict 'refs'; is($class_mop_package_meta->get_method($method_name)->body, \&{'Class::MOP::Package::' . $method_name}, '... Class::MOP::Package->get_method(' . $method_name . ') == &Class::MOP::Package::' . $method_name); } } ## check the module .... is_deeply([ sort $class_mop_module_meta->get_method_list ], [ sort @class_mop_module_methods ], '... got the correct method list for module'); foreach my $method_name (sort @class_mop_module_methods) { ok($class_mop_module_meta->has_method($method_name), '... Class::MOP::Module->has_method(' . $method_name . ')'); { no strict 'refs'; is($class_mop_module_meta->get_method($method_name)->body, \&{'Class::MOP::Module::' . $method_name}, '... Class::MOP::Module->get_method(' . $method_name . ') == &Class::MOP::Module::' . $method_name); } } # check for imported functions which are not methods foreach my $non_method_name (qw( confess blessed subname svref_2object )) { ok(!$class_mop_class_meta->has_method($non_method_name), '... NOT Class::MOP::Class->has_method(' . $non_method_name . ')'); } # check for the right attributes my @class_mop_package_attributes = ( 'package', 'namespace', ); my @class_mop_module_attributes = ( 'version', 'authority' ); my @class_mop_class_attributes = ( 'superclasses', 'instance_metaclass', 'immutable_trait', 'constructor_name', 'constructor_class', 'destructor_class', ); # check class is_deeply( [ sort $class_mop_class_meta->get_attribute_list ], [ sort @class_mop_class_attributes ], '... got the right list of attributes' ); is_deeply( [ sort keys %{$class_mop_class_meta->_attribute_map} ], [ sort @class_mop_class_attributes ], '... got the right list of attributes'); foreach my $attribute_name (sort @class_mop_class_attributes) { ok($class_mop_class_meta->has_attribute($attribute_name), '... Class::MOP::Class->has_attribute(' . $attribute_name . ')'); isa_ok($class_mop_class_meta->get_attribute($attribute_name), 'Class::MOP::Attribute'); } # check module is_deeply( [ sort $class_mop_package_meta->get_attribute_list ], [ sort @class_mop_package_attributes ], '... got the right list of attributes'); is_deeply( [ sort keys %{$class_mop_package_meta->_attribute_map} ], [ sort @class_mop_package_attributes ], '... got the right list of attributes'); foreach my $attribute_name (sort @class_mop_package_attributes) { ok($class_mop_package_meta->has_attribute($attribute_name), '... Class::MOP::Package->has_attribute(' . $attribute_name . ')'); isa_ok($class_mop_package_meta->get_attribute($attribute_name), 'Class::MOP::Attribute'); } # check package is_deeply( [ sort $class_mop_module_meta->get_attribute_list ], [ sort @class_mop_module_attributes ], '... got the right list of attributes'); is_deeply( [ sort keys %{$class_mop_module_meta->_attribute_map} ], [ sort @class_mop_module_attributes ], '... got the right list of attributes'); foreach my $attribute_name (sort @class_mop_module_attributes) { ok($class_mop_module_meta->has_attribute($attribute_name), '... Class::MOP::Module->has_attribute(' . $attribute_name . ')'); isa_ok($class_mop_module_meta->get_attribute($attribute_name), 'Class::MOP::Attribute'); } ## check the attributes themselves # ... package ok($class_mop_package_meta->get_attribute('package')->has_reader, '... Class::MOP::Class package has a reader'); is(ref($class_mop_package_meta->get_attribute('package')->reader), 'HASH', '... Class::MOP::Class package\'s a reader is { name => sub { ... } }'); ok($class_mop_package_meta->get_attribute('package')->has_init_arg, '... Class::MOP::Class package has a init_arg'); is($class_mop_package_meta->get_attribute('package')->init_arg, 'package', '... Class::MOP::Class package\'s a init_arg is package'); # ... class, but inherited from HasMethods ok($class_mop_class_meta->find_attribute_by_name('method_metaclass')->has_reader, '... Class::MOP::Class method_metaclass has a reader'); is_deeply($class_mop_class_meta->find_attribute_by_name('method_metaclass')->reader, { 'method_metaclass' => \&Class::MOP::Mixin::HasMethods::method_metaclass }, '... Class::MOP::Class method_metaclass\'s a reader is &method_metaclass'); ok($class_mop_class_meta->find_attribute_by_name('method_metaclass')->has_init_arg, '... Class::MOP::Class method_metaclass has a init_arg'); is($class_mop_class_meta->find_attribute_by_name('method_metaclass')->init_arg, 'method_metaclass', '... Class::MOP::Class method_metaclass\'s init_arg is method_metaclass'); ok($class_mop_class_meta->find_attribute_by_name('method_metaclass')->has_default, '... Class::MOP::Class method_metaclass has a default'); is($class_mop_class_meta->find_attribute_by_name('method_metaclass')->default, 'Class::MOP::Method', '... Class::MOP::Class method_metaclass\'s a default is Class::MOP:::Method'); ok($class_mop_class_meta->find_attribute_by_name('wrapped_method_metaclass')->has_reader, '... Class::MOP::Class wrapped_method_metaclass has a reader'); is_deeply($class_mop_class_meta->find_attribute_by_name('wrapped_method_metaclass')->reader, { 'wrapped_method_metaclass' => \&Class::MOP::Mixin::HasMethods::wrapped_method_metaclass }, '... Class::MOP::Class wrapped_method_metaclass\'s a reader is &wrapped_method_metaclass'); ok($class_mop_class_meta->find_attribute_by_name('wrapped_method_metaclass')->has_init_arg, '... Class::MOP::Class wrapped_method_metaclass has a init_arg'); is($class_mop_class_meta->find_attribute_by_name('wrapped_method_metaclass')->init_arg, 'wrapped_method_metaclass', '... Class::MOP::Class wrapped_method_metaclass\'s init_arg is wrapped_method_metaclass'); ok($class_mop_class_meta->find_attribute_by_name('method_metaclass')->has_default, '... Class::MOP::Class method_metaclass has a default'); is($class_mop_class_meta->find_attribute_by_name('method_metaclass')->default, 'Class::MOP::Method', '... Class::MOP::Class method_metaclass\'s a default is Class::MOP:::Method'); # ... class, but inherited from HasAttributes ok($class_mop_class_meta->find_attribute_by_name('attributes')->has_reader, '... Class::MOP::Class attributes has a reader'); is_deeply($class_mop_class_meta->find_attribute_by_name('attributes')->reader, { '_attribute_map' => \&Class::MOP::Mixin::HasAttributes::_attribute_map }, '... Class::MOP::Class attributes\'s a reader is &_attribute_map'); ok($class_mop_class_meta->find_attribute_by_name('attributes')->has_init_arg, '... Class::MOP::Class attributes has a init_arg'); is($class_mop_class_meta->find_attribute_by_name('attributes')->init_arg, 'attributes', '... Class::MOP::Class attributes\'s a init_arg is attributes'); ok($class_mop_class_meta->find_attribute_by_name('attributes')->has_default, '... Class::MOP::Class attributes has a default'); is_deeply($class_mop_class_meta->find_attribute_by_name('attributes')->default('Foo'), {}, '... Class::MOP::Class attributes\'s a default of {}'); ok($class_mop_class_meta->find_attribute_by_name('attribute_metaclass')->has_reader, '... Class::MOP::Class attribute_metaclass has a reader'); is_deeply($class_mop_class_meta->find_attribute_by_name('attribute_metaclass')->reader, { 'attribute_metaclass' => \&Class::MOP::Mixin::HasAttributes::attribute_metaclass }, '... Class::MOP::Class attribute_metaclass\'s a reader is &attribute_metaclass'); ok($class_mop_class_meta->find_attribute_by_name('attribute_metaclass')->has_init_arg, '... Class::MOP::Class attribute_metaclass has a init_arg'); is($class_mop_class_meta->find_attribute_by_name('attribute_metaclass')->init_arg, 'attribute_metaclass', '... Class::MOP::Class attribute_metaclass\'s a init_arg is attribute_metaclass'); ok($class_mop_class_meta->find_attribute_by_name('attribute_metaclass')->has_default, '... Class::MOP::Class attribute_metaclass has a default'); is($class_mop_class_meta->find_attribute_by_name('attribute_metaclass')->default, 'Class::MOP::Attribute', '... Class::MOP::Class attribute_metaclass\'s a default is Class::MOP:::Attribute'); # check the values of some of the methods is($class_mop_class_meta->name, 'Class::MOP::Class', '... Class::MOP::Class->name'); is($class_mop_class_meta->version, $Class::MOP::Class::VERSION, '... Class::MOP::Class->version'); if ( defined $Class::MOP::Class::VERSION ) { ok($class_mop_class_meta->has_package_symbol('$VERSION'), '... Class::MOP::Class->has_package_symbol($VERSION)'); } is(${$class_mop_class_meta->get_package_symbol('$VERSION')}, $Class::MOP::Class::VERSION, '... Class::MOP::Class->get_package_symbol($VERSION)'); is_deeply( [ $class_mop_class_meta->superclasses ], [ qw/Class::MOP::Module Class::MOP::Mixin::HasAttributes Class::MOP::Mixin::HasMethods/ ], '... Class::MOP::Class->superclasses == [ Class::MOP::Module ]'); is_deeply( [ $class_mop_class_meta->class_precedence_list ], [ qw/ Class::MOP::Class Class::MOP::Module Class::MOP::Package Class::MOP::Object Class::MOP::Mixin::HasAttributes Class::MOP::Mixin Class::MOP::Mixin::HasMethods Class::MOP::Mixin / ], '... Class::MOP::Class->class_precedence_list == [ Class::MOP::Class Class::MOP::Module Class::MOP::Package ]'); is($class_mop_class_meta->attribute_metaclass, 'Class::MOP::Attribute', '... got the right value for attribute_metaclass'); is($class_mop_class_meta->method_metaclass, 'Class::MOP::Method', '... got the right value for method_metaclass'); is($class_mop_class_meta->instance_metaclass, 'Class::MOP::Instance', '... got the right value for instance_metaclass'); done_testing; overloading.t100644000767000024 1173512200352344 17630 0ustar00etherstaff000000000000Moose-2.1005/t/metaclasses#!/usr/bin/env perl use strict; use warnings; use Test::More; use Test::Fatal; my $quote = qr/['`"]/; { package Foo; use Moose; } { my $meta = Foo->meta; ok(!$meta->is_overloaded); is_deeply([sort $meta->overload_operators], [sort map { split /\s+/ } values %overload::ops]); ok(!$meta->has_overloaded_operator('+')); ok(!$meta->has_overloaded_operator('-')); is_deeply([$meta->get_overload_list], []); is_deeply([$meta->get_all_overloaded_operators], []); is($meta->get_overloaded_operator('+'), undef); is($meta->get_overloaded_operator('-'), undef); } my $plus = 0; my $plus_impl; BEGIN { $plus_impl = sub { $plus = 1; "plus" } } { package Foo::Overloaded; use Moose; use overload '+' => $plus_impl; } { my $meta = Foo::Overloaded->meta; ok($meta->is_overloaded); ok($meta->has_overloaded_operator('+')); ok(!$meta->has_overloaded_operator('-')); is_deeply([$meta->get_overload_list], ['+']); my @overloads = $meta->get_all_overloaded_operators; is(scalar(@overloads), 1); my $plus_meth = $overloads[0]; isa_ok($plus_meth, 'Class::MOP::Method::Overload'); is($plus_meth->operator, '+'); is($plus_meth->name, '(+'); is($plus_meth->body, $plus_impl); is($plus_meth->package_name, 'Foo::Overloaded'); is($plus_meth->associated_metaclass, $meta); my $plus_meth2 = $meta->get_overloaded_operator('+'); { local $TODO = "we don't cache these yet"; is($plus_meth2, $plus_meth); } is($plus_meth2->operator, '+'); is($plus_meth2->body, $plus_impl); is($meta->get_overloaded_operator('-'), undef); is($plus, 0); is(Foo::Overloaded->new + Foo::Overloaded->new, "plus"); is($plus, 1); my $minus = 0; my $minus_impl = sub { $minus = 1; "minus" }; like(exception { Foo::Overloaded->new - Foo::Overloaded->new }, qr/Operation $quote-$quote: no method found/); $meta->add_overloaded_operator('-' => $minus_impl); ok($meta->has_overloaded_operator('-')); is_deeply([sort $meta->get_overload_list], ['+', '-']); is(scalar($meta->get_all_overloaded_operators), 2); my $minus_meth = $meta->get_overloaded_operator('-'); isa_ok($minus_meth, 'Class::MOP::Method::Overload'); is($minus_meth->operator, '-'); is($minus_meth->name, '(-'); is($minus_meth->body, $minus_impl); is($minus_meth->package_name, 'Foo::Overloaded'); is($minus_meth->associated_metaclass, $meta); is($minus, 0); is(Foo::Overloaded->new - Foo::Overloaded->new, "minus"); is($minus, 1); $meta->remove_overloaded_operator('-'); like(exception { Foo::Overloaded->new - Foo::Overloaded->new }, qr/Operation $quote-$quote: no method found/); } my $times = 0; my $divided = 0; { package Foo::OverloadedMethod; use Moose; use overload '*' => 'times'; sub times { $times = 1; "times" } sub divided { $divided = 1; "divided" } } { my $meta = Foo::OverloadedMethod->meta; ok($meta->is_overloaded); ok($meta->has_overloaded_operator('*')); ok(!$meta->has_overloaded_operator('/')); is_deeply([$meta->get_overload_list], ['*']); my @overloads = $meta->get_all_overloaded_operators; is(scalar(@overloads), 1); my $times_meth = $overloads[0]; isa_ok($times_meth, 'Class::MOP::Method::Overload'); is($times_meth->operator, '*'); is($times_meth->name, '(*'); is($times_meth->body, $meta->get_method('times')->body); is($times_meth->package_name, 'Foo::OverloadedMethod'); is($times_meth->associated_metaclass, $meta); my $times_meth2 = $meta->get_overloaded_operator('*'); { local $TODO = "we don't cache these yet"; is($times_meth2, $times_meth); } is($times_meth2->operator, '*'); is($times_meth2->body, $meta->get_method('times')->body); is($meta->get_overloaded_operator('/'), undef); is($times, 0); is(Foo::OverloadedMethod->new * Foo::OverloadedMethod->new, "times"); is($times, 1); like(exception { Foo::OverloadedMethod->new / Foo::OverloadedMethod->new }, qr{Operation $quote/$quote: no method found}); $meta->add_overloaded_operator('/' => 'divided'); ok($meta->has_overloaded_operator('/')); is_deeply([sort $meta->get_overload_list], ['*', '/']); is(scalar($meta->get_all_overloaded_operators), 2); my $divided_meth = $meta->get_overloaded_operator('/'); isa_ok($divided_meth, 'Class::MOP::Method::Overload'); is($divided_meth->operator, '/'); is($divided_meth->name, '(/'); is($divided_meth->body, $meta->get_method('divided')->body); is($divided_meth->package_name, 'Foo::OverloadedMethod'); is($divided_meth->associated_metaclass, $meta); is($divided, 0); is(Foo::OverloadedMethod->new / Foo::OverloadedMethod->new, "divided"); is($divided, 1); $meta->remove_overloaded_operator('/'); like(exception { Foo::OverloadedMethod->new / Foo::OverloadedMethod->new }, qr{Operation $quote/$quote: no method found}); } done_testing; throw_error.t100644000767000024 1367512200352344 17700 0ustar00etherstaff000000000000Moose-2.1005/t/metaclasses#!/usr/bin/perl use strict; use warnings; use Test::More; use Test::Fatal; use Test::Moose; { package Foo; use Moose; has foo => ( is => "ro" ); package Bar; use metaclass ( metaclass => "Moose::Meta::Class", error_class => "Moose::Error::Croak", ); use Moose; has foo => ( is => "ro" ); BEGIN { package Baz::Error; use Moose; extends 'Moose::Object', 'Moose::Error::Default'; has message => ( isa => "Str", is => "ro" ); has attr => ( isa => "Moose::Meta::Attribute", is => "ro" ); has method => ( isa => "Moose::Meta::Method", is => "ro" ); has metaclass => ( isa => "Moose::Meta::Class", is => "ro" ); has data => ( is => "ro" ); has line => ( isa => "Int", is => "ro" ); has file => ( isa => "Str", is => "ro" ); has last_error => ( isa => "Any", is => "ro" ); } package Baz; use metaclass ( metaclass => "Moose::Meta::Class", error_class => "Baz::Error", ); use Moose; has foo => ( is => "ro" ); } my $line; sub blah { $line = __LINE__; shift->foo(4) } sub create_error { eval { eval { die "Blah" }; blah(shift); }; ok( my $e = $@, "got some error" ); return { file => __FILE__, line => $line, error => $e, }; } with_immutable { { my $e = create_error( Foo->new ); ok( !ref( $e->{error} ), "error is a string" ); like( $e->{error}, qr/line $e->{line}\n.*\n/s, "confess" ); } { my $e = create_error( Bar->new ); ok( !ref( $e->{error} ), "error is a string" ); like( $e->{error}, qr/line $e->{line}\.?$/s, "croak" ); } { my $e = create_error( my $baz = Baz->new ); isa_ok( $e->{error}, "Baz::Error" ); unlike( $e->{error}->message, qr/line $e->{line}/s, "no line info, just a message" ); isa_ok( $e->{error}->metaclass, "Moose::Meta::Class", "metaclass" ); is( $e->{error}->metaclass, Baz->meta, "metaclass value" ); isa_ok( $e->{error}->attr, "Moose::Meta::Attribute", "attr" ); is( $e->{error}->attr, Baz->meta->get_attribute("foo"), "attr value" ); isa_ok( $e->{error}->method, "Moose::Meta::Method", "method" ); is( $e->{error}->method, Baz->meta->get_method("foo"), "method value" ); is( $e->{error}->line, $e->{line}, "line attr" ); is( $e->{error}->file, $e->{file}, "file attr" ); is_deeply( $e->{error}->data, [ $baz, 4 ], "captured args" ); like( $e->{error}->last_error, qr/Blah/, "last error preserved" ); } } 'Foo', 'Bar', 'Baz'; { package Role::Foo; use Moose::Role; sub foo { } } { package Baz::Sub; use Moose; extends 'Baz'; Moose::Util::MetaRole::apply_metaroles( for => __PACKAGE__, class_metaroles => { class => ['Role::Foo'] }, ); } { package Baz::Sub::Sub; use metaclass ( metaclass => 'Moose::Meta::Class', error_class => 'Moose::Error::Croak', ); use Moose; ::isnt( ::exception { extends 'Baz::Sub' }, undef, 'error_class is included in metaclass compatibility checks' ); } { package Foo::Sub; use metaclass ( metaclass => 'Moose::Meta::Class', error_class => 'Moose::Error::Croak', ); use Moose; Moose::Util::MetaRole::apply_metaroles( for => __PACKAGE__, class_metaroles => { class => ['Role::Foo'] }, ); } ok( Foo::Sub->meta->error_class->isa('Moose::Error::Croak'), q{Foo::Sub's error_class still isa Moose::Error::Croak} ); { package Foo::Sub::Sub; use Moose; ::is( ::exception { extends 'Foo::Sub' }, undef, 'error_class differs by role so incompat is handled' ); Moose::Util::MetaRole::apply_metaroles( for => __PACKAGE__, class_metaroles => { error => ['Role::Foo'] }, ); } ok( Foo::Sub::Sub->meta->error_class->meta->does_role('Role::Foo'), q{Foo::Sub::Sub's error_class does Role::Foo} ); ok( Foo::Sub::Sub->meta->error_class->isa('Moose::Error::Croak'), q{Foo::Sub::Sub's error_class now subclasses Moose::Error::Croak} ); { package Quux::Default; use Moose; has foo => (is => 'ro'); sub bar { shift->foo(1) } } { package Quux::Croak; use metaclass 'Moose::Meta::Class', error_class => 'Moose::Error::Croak'; use Moose; has foo => (is => 'ro'); sub bar { shift->foo(1) } } { package Quux::Confess; use metaclass 'Moose::Meta::Class', error_class => 'Moose::Error::Confess'; use Moose; has foo => (is => 'ro'); sub bar { shift->foo(1) } } sub stacktrace_ok (&) { local $Test::Builder::Level = $Test::Builder::Level + 1; my $code = shift; eval { $code->() }; my @lines = split /\n/, $@; cmp_ok(scalar(@lines), '>', 1, "got a stacktrace"); } sub stacktrace_not_ok (&) { local $Test::Builder::Level = $Test::Builder::Level + 1; my $code = shift; eval { $code->() }; my @lines = split /\n/, $@; cmp_ok(scalar(@lines), '==', 1, "didn't get a stacktrace"); } with_immutable { my $default = Quux::Default->new; my $croak = Quux::Croak->new; my $confess = Quux::Confess->new; is($default->meta->error_class, 'Moose::Error::Default'); is($croak->meta->error_class, 'Moose::Error::Croak'); is($confess->meta->error_class, 'Moose::Error::Confess'); { local $ENV{MOOSE_ERROR_STYLE}; stacktrace_ok { $default->bar }; stacktrace_not_ok { $croak->bar }; stacktrace_ok { $confess->bar }; } { local $ENV{MOOSE_ERROR_STYLE} = 'croak'; stacktrace_not_ok { $default->bar }; stacktrace_not_ok { $croak->bar }; stacktrace_ok { $confess->bar }; } { local $ENV{MOOSE_ERROR_STYLE} = 'confess'; stacktrace_ok { $default->bar }; stacktrace_not_ok { $croak->bar }; stacktrace_ok { $confess->bar }; } } 'Quux::Default', 'Quux::Croak', 'Quux::Confess'; done_testing; create_alias.t100644000767000024 465512200352344 17571 0ustar00etherstaff000000000000Moose-2.1005/t/moose_util#!/usr/bin/perl use strict; use warnings; use Test::More; use Test::Moose qw(does_ok); BEGIN { package Foo::Meta::Role; use Moose::Role; Moose::Util::meta_class_alias FooRole => 'Foo::Meta::Role'; package Foo::Meta::Class; use Moose; extends 'Moose::Meta::Class'; with 'Foo::Meta::Role'; Moose::Util::meta_class_alias FooClass => 'Foo::Meta::Class'; package Foo::Meta::Role::Attribute; use Moose::Role; Moose::Util::meta_attribute_alias FooAttrRole => 'Foo::Meta::Role::Attribute'; package Foo::Meta::Attribute; use Moose; extends 'Moose::Meta::Attribute'; with 'Foo::Meta::Role::Attribute'; Moose::Util::meta_attribute_alias FooAttrClass => 'Foo::Meta::Attribute'; package Bar::Meta::Role; use Moose::Role; Moose::Util::meta_class_alias 'BarRole'; package Bar::Meta::Class; use Moose; extends 'Moose::Meta::Class'; with 'Bar::Meta::Role'; Moose::Util::meta_class_alias 'BarClass'; package Bar::Meta::Role::Attribute; use Moose::Role; Moose::Util::meta_attribute_alias 'BarAttrRole'; package Bar::Meta::Attribute; use Moose; extends 'Moose::Meta::Attribute'; with 'Bar::Meta::Role::Attribute'; Moose::Util::meta_attribute_alias 'BarAttrClass'; } package FooWithMetaClass; use Moose -metaclass => 'FooClass'; has bar => ( metaclass => 'FooAttrClass', is => 'ro', ); package FooWithMetaTrait; use Moose -traits => 'FooRole'; has bar => ( traits => [qw(FooAttrRole)], is => 'ro', ); package BarWithMetaClass; use Moose -metaclass => 'BarClass'; has bar => ( metaclass => 'BarAttrClass', is => 'ro', ); package BarWithMetaTrait; use Moose -traits => 'BarRole'; has bar => ( traits => [qw(BarAttrRole)], is => 'ro', ); package main; my $fwmc_meta = FooWithMetaClass->meta; my $fwmt_meta = FooWithMetaTrait->meta; isa_ok($fwmc_meta, 'Foo::Meta::Class'); isa_ok($fwmc_meta->get_attribute('bar'), 'Foo::Meta::Attribute'); does_ok($fwmt_meta, 'Foo::Meta::Role'); does_ok($fwmt_meta->get_attribute('bar'), 'Foo::Meta::Role::Attribute'); my $bwmc_meta = BarWithMetaClass->meta; my $bwmt_meta = BarWithMetaTrait->meta; isa_ok($bwmc_meta, 'Bar::Meta::Class'); isa_ok($bwmc_meta->get_attribute('bar'), 'Bar::Meta::Attribute'); does_ok($bwmt_meta, 'Bar::Meta::Role'); does_ok($bwmt_meta->get_attribute('bar'), 'Bar::Meta::Role::Attribute'); done_testing; specio.t100644000767000024 1256712200352344 17711 0ustar00etherstaff000000000000Moose-2.1005/t/type_constraints#!/usr/bin/perl use strict; use warnings; # Prevent namespace::autoclean from dying when we run tests from git checkout. use Class::MOP (); use Moose (); BEGIN { $Class::MOP::VERSION ||= $Moose::VERSION ||= 3 } use Test::Fatal; use Test::Moose qw( with_immutable ); use Test::More; use Test::Requires { 'Specio' => '0.07', }; { package Foo; use Moose; use Specio::Library::Builtins; has int => ( is => 'ro', isa => t('Int'), ); has array_of_ints => ( is => 'ro', isa => t( 'ArrayRef', of => t('Int') ), ); has hash_of_ints => ( is => 'ro', isa => t( 'HashRef', of => t('Int') ), ); } with_immutable( sub { my $is_immutable = shift; subtest( 'Foo class' . ( $is_immutable ? ' (immutable)' : q{} ), sub { is( exception { Foo->new( int => 42 ) }, undef, '42 is an acceptable int' ); like( exception { Foo->new( int => 42.4 ) }, qr/does not pass the type constraint.+for type named Int/, '42.4 is not an acceptable int' ); is( exception { Foo->new( array_of_ints => [ 42, 84 ] ) }, undef, '[ 42, 84 ] is an acceptable array of ints' ); like( exception { Foo->new( array_of_ints => [ 42.4, 84 ] ) }, qr/does not pass the type constraint.+for anonymous type/, '[ 42.4, 84 ] is an acceptable array of ints' ); is( exception { Foo->new( hash_of_ints => { foo => 42, bar => 84 } ); }, undef, '{ foo => 42, bar => 84 } is an acceptable array of ints' ); like( exception { Foo->new( hash_of_ints => { foo => 42.4, bar => 84 } ); }, qr/does not pass the type constraint.+for anonymous type/, '{ foo => 42.4, bar => 84 } is an acceptable array of ints' ); } ); }, 'Foo' ); { package Bar; use Moose; use Specio::Declare; use Specio::Library::Builtins; my $array_of_ints = anon( parent => t( 'ArrayRef', of => t('Int') ) ); coerce( $array_of_ints, from => t('Int'), using => sub { return [ $_[0] ]; } ); has array_of_ints => ( is => 'ro', isa => $array_of_ints, coerce => 1, ); my $hash_of_ints = anon( parent => t( 'HashRef', of => t('Int') ) ); coerce( $hash_of_ints, from => t('Int'), using => sub { return { foo => $_[0] }; } ); has hash_of_ints => ( is => 'ro', isa => $hash_of_ints, coerce => 1, ); } with_immutable( sub { my $is_immutable = shift; subtest( 'Bar class' . ( $is_immutable ? ' (immutable)' : q{} ), sub { is( exception { Bar->new( array_of_ints => [ 42, 84 ] ) }, undef, '[ 42, 84 ] is an acceptable array of ints' ); like( exception { Bar->new( array_of_ints => [ 42.4, 84 ] ) }, qr/does not pass the type constraint.+for anonymous type/, '[ 42.4, 84 ] is an acceptable array of ints' ); { my $bar; is( exception { $bar = Bar->new( array_of_ints => 42 ) }, undef, '42 is an acceptable array of ints with coercion' ); is_deeply( $bar->array_of_ints(), [42], 'int is coerced to single element arrayref' ); } is( exception { Bar->new( hash_of_ints => { foo => 42, bar => 84 } ); }, undef, '{ foo => 42, bar => 84 } is an acceptable array of ints' ); like( exception { Bar->new( hash_of_ints => { foo => 42.4, bar => 84 } ); }, qr/does not pass the type constraint.+for anonymous type/, '{ foo => 42.4, bar => 84 } is an acceptable array of ints' ); { my $bar; is( exception { $bar = Bar->new( hash_of_ints => 42 ) }, undef, '42 is an acceptable hash of ints with coercion' ); is_deeply( $bar->hash_of_ints(), { foo => 42 }, 'int is coerced to single element hashref' ); } } ); }, 'Bar' ); done_testing(); convert-to-test-fatal100755000767000024 552312200352344 17733 0ustar00etherstaff000000000000Moose-2.1005/author#!/usr/bin/perl use strict; use warnings; use File::Slurp qw( write_file ); use PPI; rewrite_doc($_) for grep { -w } @ARGV; sub rewrite_doc { my $file = shift; my $doc = PPI::Document->new($file); return unless $doc =~ /Test::Exception/; print $file, "\n"; my $pattern = sub { my $elt = $_[1]; return 1 if $elt->isa('PPI::Statement') && $elt->content() =~ /^\s*(?:::)?(?:lives_|throws_|dies_)(?:ok|and)/; return 0; }; for my $elt ( @{ $doc->find($pattern) || [] } ) { transform_statement($elt); } my $content = $doc->content(); $content =~ s/Test::Exception/Test::Fatal/g; write_file( $file, $content ); } sub transform_statement { my $stmt = shift; my @children = $stmt->schildren; my $func = shift @children; my $colons = $func =~ /^::/ ? '::' : q{}; my $code; if ( $func =~ /lives_/ ) { $code = function( $colons . 'is', $children[0], 'undef', $children[1] ); } elsif ( $func =~ /dies_/ ) { $code = function( $colons . 'isnt', $children[0], 'undef', $children[1] ); } elsif ( $func =~ /throws_/ ) { # $children[2] is always a comma if it exists if ( $children[1]->isa('PPI::Token::QuoteLike::Regexp') ) { $code = function( $colons . 'like', $children[0], $children[1], $children[3] ); } else { $code = function( $colons . 'is', $children[0], $children[1], $children[3] ); } } $stmt->insert_before($code); $stmt->remove; } sub function { my $func = shift; my $exception = shift; my $expect = shift; my $desc = shift; my $exc_func = $func =~ /^::/ ? '::exception' : 'exception'; my @code; push @code, PPI::Token::Word->new($func), PPI::Token::Structure->new('('), PPI::Token::Whitespace->new(q{ }), PPI::Token::Word->new($exc_func), PPI::Token::Whitespace->new(q{ }), $exception->clone, PPI::Token::Operator->new(','), PPI::Token::Whitespace->new(q{ }), ( ref $expect ? $expect->clone : PPI::Token::Word->new($expect) ); if ( $desc && $desc->isa('PPI::Token::Quote') ) { push @code, PPI::Token::Operator->new(','), PPI::Token::Whitespace->new(q{ }), $desc->clone; } push @code, PPI::Token::Whitespace->new(q{ }), PPI::Token::Structure->new(')'), PPI::Token::Structure->new(';'); my $stmt = PPI::Statement->new; $stmt->add_element($_) for @code; return $stmt; } simple_compile.pl100600000767000024 77612200352344 17771 0ustar00etherstaff000000000000Moose-2.1005/benchmarks#!/usr/bin/perl use strict; use warnings; use Benchmark::Forking qw[cmpthese]; =pod This compare the overhead of Class::MOP to the overhead of Moose. The goal here is to see how much more startup cost Moose adds to Class::MOP. NOTE: This benchmark may not be all that relevant really, but it's helpful to see maybe. =cut cmpthese(5_000, { 'w/out_moose' => sub { eval 'use Class::MOP;'; }, 'w_moose' => sub { eval 'use Moose;'; }, } ); 1;Method000755000767000024 012200352344 15662 5ustar00etherstaff000000000000Moose-2.1005/lib/Class/MOPMeta.pm100644000767000024 741012200352344 17250 0ustar00etherstaff000000000000Moose-2.1005/lib/Class/MOP/Method package Class::MOP::Method::Meta; BEGIN { $Class::MOP::Method::Meta::AUTHORITY = 'cpan:STEVAN'; } { $Class::MOP::Method::Meta::VERSION = '2.1005'; } use strict; use warnings; use Carp 'confess'; use Scalar::Util 'blessed', 'weaken'; use constant DEBUG_NO_META => $ENV{DEBUG_NO_META} ? 1 : 0; use base 'Class::MOP::Method'; sub _is_caller_mop_internal { my $self = shift; my ($caller) = @_; return $caller =~ /^(?:Class::MOP|metaclass)(?:::|$)/; } sub _generate_meta_method { my $method_self = shift; my $metaclass = shift; weaken($metaclass); sub { # this will be compiled out if the env var wasn't set if (DEBUG_NO_META) { confess "'meta' method called by MOP internals" # it's okay to call meta methods on metaclasses, since we # explicitly ask for them if !$_[0]->isa('Class::MOP::Object') && !$_[0]->isa('Class::MOP::Mixin') # it's okay if the test itself calls ->meta, we only care about # if the mop internals call ->meta && $method_self->_is_caller_mop_internal(scalar caller); } # we must re-initialize so that it # works as expected in subclasses, # since metaclass instances are # singletons, this is not really a # big deal anyway. $metaclass->initialize(blessed($_[0]) || $_[0]) }; } sub wrap { my ($class, @args) = @_; unshift @args, 'body' if @args % 2 == 1; my %params = @args; confess "Overriding the body of meta methods is not allowed" if $params{body}; my $metaclass_class = $params{associated_metaclass}->meta; $params{body} = $class->_generate_meta_method($metaclass_class); return $class->SUPER::wrap(%params); } sub _make_compatible_with { my $self = shift; my ($other) = @_; # XXX: this is pretty gross. the issue here is that CMOP::Method::Meta # objects are subclasses of CMOP::Method, but when we get to moose, they'll # need to be compatible with Moose::Meta::Method, which isn't possible. the # right solution here is to make ::Meta into a role that gets applied to # whatever the method_metaclass happens to be and get rid of # _meta_method_metaclass entirely, but that's not going to happen until # we ditch cmop and get roles into the bootstrapping, so. i'm not # maintaining the previous behavior of turning them into instances of the # new method_metaclass because that's equally broken, and at least this way # any issues will at least be detectable and potentially fixable. -doy return $self unless $other->_is_compatible_with($self->_real_ref_name); return $self->SUPER::_make_compatible_with(@_); } 1; # ABSTRACT: Method Meta Object for C methods __END__ =pod =head1 NAME Class::MOP::Method::Meta - Method Meta Object for C methods =head1 VERSION version 2.1005 =head1 DESCRIPTION This is a L subclass which represents C methods installed into classes by Class::MOP. =head1 METHODS =over 4 =item B<< Class::MOP::Method::Wrapped->wrap($metamethod, %options) >> This is the constructor. It accepts a L object and a hash of options. The options accepted are identical to the ones accepted by L, except that C cannot be passed (it will be generated automatically). =back =head1 AUTHOR Moose is maintained by the Moose Cabal, along with the help of many contributors. See L and L for details. =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2013 by Infinity Interactive, Inc.. This is free software; you can redistribute it and/or modify it under the same terms as the Perl 5 programming language system itself. =cut Cookbook000755000767000024 012200352344 15572 5ustar00etherstaff000000000000Moose-2.1005/lib/MooseStyle.pod100644000767000024 151712200352344 17542 0ustar00etherstaff000000000000Moose-2.1005/lib/Moose/Cookbookpackage Moose::Cookbook::Style; # ABSTRACT: Expanded into Moose::Manual::BestPractices, so go read that __END__ =pod =head1 NAME Moose::Cookbook::Style - Expanded into Moose::Manual::BestPractices, so go read that =head1 VERSION version 2.1005 =head1 DESCRIPTION The style cookbook has been replaced by L. This POD document still exists for the benefit of anyone out there who might've linked to it in the past. =head1 AUTHOR Moose is maintained by the Moose Cabal, along with the help of many contributors. See L and L for details. =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2013 by Infinity Interactive, Inc.. This is free software; you can redistribute it and/or modify it under the same terms as the Perl 5 programming language system itself. =cut Classes.pod100644000767000024 1150112200352344 17520 0ustar00etherstaff000000000000Moose-2.1005/lib/Moose/Manualpackage Moose::Manual::Classes; # ABSTRACT: Making your classes use Moose (and subclassing) __END__ =pod =head1 NAME Moose::Manual::Classes - Making your classes use Moose (and subclassing) =head1 VERSION version 2.1005 =head1 USING MOOSE Using Moose is very simple, you just C: package Person; use Moose; That's it, you've made a class with Moose! There's actually a lot going on here under the hood, so let's step through it. When you load L, a bunch of sugar functions are exported into your class, such as C, C, C, and more. These functions are what you use to define your class. For example, you might define an attribute ... package Person; use Moose; has 'ssn' => ( is => 'rw' ); Attributes are described in the L documentation. Loading Moose also enables the C and C pragmas in your class. When you load Moose, your class will become a subclass of L. The L class provides a default constructor and destructor, as well as object construction helper methods. You can read more about this in the L document. As a convenience, Moose creates a new class type for your class. See the L document to learn more about types. It also creates a L object for your class. This metaclass object is now available by calling a C method on your class, for example C<< Person->meta >>. The metaclass object provides an introspection API for your class. It is also used by Moose itself under the hood to add attributes, define parent classes, and so on. In fact, all of Moose's sugar does the real work by calling methods on this metaclass object (and other meta API objects). =head1 SUBCLASSING Moose provides a simple sugar function for declaring your parent classes, C: package User; use Moose; extends 'Person'; has 'username' => ( is => 'rw' ); Note that each call to C will I your parents. For multiple inheritance you must provide all the parents at once, C. When you call C Moose will try to load any classes you pass. You can use Moose to extend a non-Moose parent. However, when you do this, you will inherit the parent class's constructor (assuming it is also called C). In that case, you will have to take care of initializing attributes manually, either in the parent's constructor, or in your subclass, and you will lose a lot of Moose magic. See the L module on CPAN if you're interested in extending non-Moose parent classes with Moose child classes. =head1 CLEANING UP MOOSE DROPPINGS Moose exports a number of functions into your class. It's a good idea to remove these sugar functions from your class's namespace, so that C<< Person->can('has') >> will no longer return true. There are several ways to do this. We recommend using L, a CPAN module. Not only will it remove Moose exports, it will also remove any other exports. package Person; use namespace::autoclean; use Moose; If you absolutely can't use a CPAN module (but can use Moose?), you can write C at the end of your class. This will remove any Moose exports in your class. package Person; use Moose; has 'ssn' => ( is => 'rw' ); no Moose; =head1 MAKING IT FASTER Moose has a feature called "immutabilization" that you can use to greatly speed up your classes at runtime. However, using it incurs a cost when your class is first being loaded. When you make your class immutable you tell Moose that you will not be changing it in the future. You will not be adding any more attributes, methods, roles, etc. This allows Moose to generate code specific to your class. In particular, it creates an "inline" constructor, making object construction much faster. To make your class immutable you simply call C on your class's metaclass object. __PACKAGE__->meta->make_immutable; =head2 Immutabilization and C If you override C in your class, then the immutabilization code will not be able to provide an optimized constructor for your class. Instead, you should use a C method, which will be called from the inlined constructor. Alternately, if you really need to provide a different C, you can also provide your own immutabilization method. Doing so requires extending the Moose metaclasses, and is well beyond the scope of this manual. =head1 AUTHOR Moose is maintained by the Moose Cabal, along with the help of many contributors. See L and L for details. =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2013 by Infinity Interactive, Inc.. This is free software; you can redistribute it and/or modify it under the same terms as the Perl 5 programming language system itself. =cut Support.pod100644000767000024 1452312200352344 17606 0ustar00etherstaff000000000000Moose-2.1005/lib/Moose/Manualpackage Moose::Manual::Support # ABSTRACT: Policies regarding support, releases, and compatibility. __END__ =pod =head1 NAME Moose::Manual::Support - Policies regarding support, releases, and compatibility. =head1 VERSION version 2.1005 =head1 SUPPORT POLICY There are two principles to Moose's policy of supported behavior. =over 4 =item 1. Moose favors correctness over everything. =item 2. Moose supports documented and tested behavior, not accidental behavior or side effects. =back If a behavior has never been documented or tested, the behavior is I undefined. Relying upon undocumented and untested behavior is done at your own risk. If a behavior is documented or tested but found to be incorrect later, the behavior will go through a deprecation period. During the deprecation period, use of that feature will cause a warning. Eventually, the deprecated feature will be removed. In some cases, it is not possible to deprecate a behavior. In this case, the behavior will simply be changed in a major release. =head1 RELEASE SCHEDULE Moose is on a system of quarterly major releases, with minor releases as needed between major releases. A minor release is defined as one that makes every attempt to preserve backwards compatibility. Currently this means that we did not introduce any new dependency conflicts, and that we did not make any changes to documented or tested behavior (this typically means that minor releases will not change any existing tests in the test suite, although they can add new ones). A minor release can include new features and bug fixes. Major releases may be backwards incompatible. Moose prioritizes correctness over backwards compatibility or performance; see the L to understand how backwards incompatible changes are announced. Major releases are scheduled to happen during fixed release windows. If the window is missed, then there will not be a major release until the next release window. The release windows are one month long, and occur during the months of January, April, July, and October. Before a major release, a series of development releases will be made so that users can test the upcoming major release before it is distributed to CPAN. It is in the best interests of everyone involved if these releases are tested as widely as possible. =head1 DEPRECATION POLICY Moose has always prioritized correctness over performance and backwards compatibility. Major deprecations or API changes are documented in the Changes file as well as in L. The Moose developers will also make an effort to warn users of upcoming deprecations and breakage through the Moose blog (http://blog.moose.perl.org). Deprecated APIs will be preserved for at least one year I. Deprecated APIs will only be removed in a major release. Moose will also warn during installation if the version of Moose being installed will break an installed dependency. Unfortunately, due to the nature of the Perl install process these warnings may be easy to miss. =head1 BACKWARDS COMPATIBILITY We try to ensure compatibility by having a extensive test suite (last count just over around 5123 tests), as well as testing a number of packages (currently just under 100 packages) that depend on Moose before any release. The current list of downstream dependencies that are tested is in C. =head1 VERSION NUMBERS Moose version numbers consist of three parts, in the form X.YYZZ. The X is the "special magic number" that only gets changed for really big changes. Think of this as being like the "5" in Perl 5.12.1. The YY portion is the major version number. Moose uses even numbers for stable releases, and odd numbers for trial releases. The ZZ is the minor version, and it simply increases monotonically. It starts at "00" each time a new major version is released. Semantically, this means that any two releases which share a major version should be API-compatible with each other. In other words, 2.0200, 2.0201, and 2.0274 are all API-compatible. Prior to version 2.0, Moose version numbers were monotonically incrementing two decimal values (0.01, 0.02, ... 1.11, 1.12, etc.). Moose was declared production ready at version 0.18 (via L<< http://www.perlmonks.org/?node_id=608144 >>). =head1 PERL VERSION COMPATIBILITY As of version 2.00, Moose officially supports being run on perl 5.8.3+. Our current policy is to support the earliest version of Perl shipped in the latest stable release of any major operating system (this tends to mean CentOS). We will provide at least six months notice (two major releases) when we decide to increase the officially supported Perl version. The next time this will happen is in January of 2012, when Moose 2.06 will increase the minimum officially supported Perl version to 5.10.1. "Officially supported" does not mean that these are the only versions of Perl that Moose will work with. Our declared perl dependency will remain at 5.8.3 as long as our test suite continues to pass on 5.8.3. What this does mean is that the core Moose dev team will not be spending any time fixing bugs on versions that aren't officially supported, and new contributions will not be rejected due to being incompatible with older versions of perl except in the most trivial of cases. We will, however, still welcome patches to make Moose compatible with earlier versions, if other people are still interested in maintaining compatibility. Note that although performance regressions are acceptable in order to maintain backwards compatibility (as long as they only affect the older versions), functionality changes and buggy behavior will not be. If it becomes impossible to provide identical functionality between modern Perl versions and unsupported Perl versions, we will increase our declared perl dependency instead. =head1 CONTRIBUTING Moose has an open contribution policy. Anybody is welcome to submit a patch. Please see L for more details. =head1 AUTHOR Moose is maintained by the Moose Cabal, along with the help of many contributors. See L and L for details. =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2013 by Infinity Interactive, Inc.. This is free software; you can redistribute it and/or modify it under the same terms as the Perl 5 programming language system itself. =cut default_undef.t100644000767000024 55212200352344 17741 0ustar00etherstaff000000000000Moose-2.1005/t/attributes#!/usr/bin/env perl use strict; use warnings; use Test::More; use Test::Moose; { package Foo; use Moose; has foo => ( is => 'ro', isa => 'Maybe[Int]', default => undef, predicate => 'has_foo', ); } with_immutable { is(Foo->new->foo, undef); ok(Foo->new->has_foo); } 'Foo'; done_testing; basic_class_setup.t100644000767000024 241112200352344 17714 0ustar00etherstaff000000000000Moose-2.1005/t/basics#!/usr/bin/perl use strict; use warnings; use Test::More; use Test::Fatal; { package Foo; use Moose; use Moose::Util::TypeConstraints; } can_ok('Foo', 'meta'); isa_ok(Foo->meta, 'Moose::Meta::Class'); ok(Foo->meta->has_method('meta'), '... we got the &meta method'); ok(Foo->isa('Moose::Object'), '... Foo is automagically a Moose::Object'); isnt( exception { Foo->meta->has_method() }, undef, '... has_method requires an arg' ); can_ok('Foo', 'does'); foreach my $function (qw( extends has before after around blessed confess type subtype as where coerce from via find_type_constraint )) { ok(!Foo->meta->has_method($function), '... the meta does not treat "' . $function . '" as a method'); } foreach my $import (qw( blessed try catch in_global_destruction )) { ok(!Moose::Object->can($import), "no namespace pollution in Moose::Object ($import)" ); local $TODO = $import eq 'blessed' ? "no automatic namespace cleaning yet" : undef; ok(!Foo->can($import), "no namespace pollution in Moose::Object ($import)" ); } done_testing; buildargs_warning.t100644000767000024 155012200352344 17732 0ustar00etherstaff000000000000Moose-2.1005/t/basics#!/usr/bin/perl use strict; use warnings; use Test::Fatal; use Test::More; use Test::Moose qw( with_immutable ); use Test::Requires { 'Test::Output' => '0.01', }; { package Baz; use Moose; } with_immutable { is( exception { stderr_like { Baz->new( x => 42, 'y' ) } qr{\QThe new() method for Baz expects a hash reference or a key/value list. You passed an odd number of arguments at $0 line \E\d+}, 'warning when passing an odd number of args to new()'; stderr_unlike { Baz->new( x => 42, 'y' ) } qr{\QOdd number of elements in anonymous hash}, 'we suppress the standard warning from Perl for an odd number of elements in a hash'; stderr_is { Baz->new( { x => 42 } ) } q{}, 'we handle a single hashref to new without errors'; }, undef ); } 'Baz'; done_testing; inner_and_augment.t100644000767000024 505112200352344 17706 0ustar00etherstaff000000000000Moose-2.1005/t/basics#!/usr/bin/perl use strict; use warnings; use Test::More; use Test::Fatal; { package Foo; use Moose; sub foo { 'Foo::foo(' . (inner() || '') . ')' } sub bar { 'Foo::bar(' . (inner() || '') . ')' } sub baz { 'Foo::baz(' . (inner() || '') . ')' } package Bar; use Moose; extends 'Foo'; augment foo => sub { 'Bar::foo(' . (inner() || '') . ')' }; augment bar => sub { 'Bar::bar' }; no Moose; # ensure inner() still works after unimport package Baz; use Moose; extends 'Bar'; augment foo => sub { 'Baz::foo' }; augment baz => sub { 'Baz::baz' }; # this will actually never run, # because Bar::bar does not call inner() augment bar => sub { 'Baz::bar' }; } my $baz = Baz->new(); isa_ok($baz, 'Baz'); isa_ok($baz, 'Bar'); isa_ok($baz, 'Foo'); is($baz->foo(), 'Foo::foo(Bar::foo(Baz::foo))', '... got the right value from &foo'); is($baz->bar(), 'Foo::bar(Bar::bar)', '... got the right value from &bar'); is($baz->baz(), 'Foo::baz(Baz::baz)', '... got the right value from &baz'); my $bar = Bar->new(); isa_ok($bar, 'Bar'); isa_ok($bar, 'Foo'); is($bar->foo(), 'Foo::foo(Bar::foo())', '... got the right value from &foo'); is($bar->bar(), 'Foo::bar(Bar::bar)', '... got the right value from &bar'); is($bar->baz(), 'Foo::baz()', '... got the right value from &baz'); my $foo = Foo->new(); isa_ok($foo, 'Foo'); is($foo->foo(), 'Foo::foo()', '... got the right value from &foo'); is($foo->bar(), 'Foo::bar()', '... got the right value from &bar'); is($foo->baz(), 'Foo::baz()', '... got the right value from &baz'); # test saved state when crossing objects { package X; use Moose; has name => (is => 'rw'); sub run { "$_[0]->{name}.X", inner() } package Y; use Moose; extends 'X'; augment 'run' => sub { "$_[0]->{name}.Y", ($_[1] ? $_[1]->() : ()), inner(); }; package Z; use Moose; extends 'Y'; augment 'run' => sub { "$_[0]->{name}.Z" } } is('a.X a.Y b.X b.Y b.Z a.Z', do { my $a = Z->new(name => 'a'); my $b = Z->new(name => 'b'); join(' ', $a->run(sub { $b->run })) }, 'State is saved when cross-calling augmented methods on different objects'); # some error cases { package Bling; use Moose; sub bling { 'Bling::bling' } package Bling::Bling; use Moose; extends 'Bling'; sub bling { 'Bling::bling' } ::isnt( ::exception { augment 'bling' => sub {}; }, undef, '... cannot augment a method which has a local equivalent' ); } done_testing; moose_object_does.t100644000767000024 623412200352344 17717 0ustar00etherstaff000000000000Moose-2.1005/t/basicsuse strict; use warnings; use Test::More; use Test::Moose; { package Role::A; use Moose::Role } { package Role::B; use Moose::Role } { package Foo; use Moose; } { package Bar; use Moose; with 'Role::A'; } { package Baz; use Moose; with qw( Role::A Role::B ); } { package Foo::Child; use Moose; extends 'Foo'; } { package Bar::Child; use Moose; extends 'Bar'; } { package Baz::Child; use Moose; extends 'Baz'; } with_immutable { for my $thing ( 'Foo', Foo->new, 'Foo::Child', Foo::Child->new ) { my $name = ref $thing ? (ref $thing) . ' object' : "$thing class"; $name .= ' (immutable)' if $thing->meta->is_immutable; ok( !$thing->does('Role::A'), "$name does not do Role::A" ); ok( !$thing->does('Role::B'), "$name does not do Role::B" ); ok( !$thing->does( Role::A->meta ), "$name does not do Role::A (passed as object)" ); ok( !$thing->does( Role::B->meta ), "$name does not do Role::B (passed as object)" ); ok( !$thing->DOES('Role::A'), "$name does not do Role::A (using DOES)" ); ok( !$thing->DOES('Role::B'), "$name does not do Role::B (using DOES)" ); } for my $thing ( 'Bar', Bar->new, 'Bar::Child', Bar::Child->new ) { my $name = ref $thing ? (ref $thing) . ' object' : "$thing class"; $name .= ' (immutable)' if $thing->meta->is_immutable; ok( $thing->does('Role::A'), "$name does Role::A" ); ok( !$thing->does('Role::B'), "$name does not do Role::B" ); ok( $thing->does( Role::A->meta ), "$name does Role::A (passed as object)" ); ok( !$thing->does( Role::B->meta ), "$name does not do Role::B (passed as object)" ); ok( $thing->DOES('Role::A'), "$name does Role::A (using DOES)" ); ok( !$thing->DOES('Role::B'), "$name does not do Role::B (using DOES)" ); } for my $thing ( 'Baz', Baz->new, 'Baz::Child', Baz::Child->new ) { my $name = ref $thing ? (ref $thing) . ' object' : "$thing class"; $name .= ' (immutable)' if $thing->meta->is_immutable; ok( $thing->does('Role::A'), "$name does Role::A" ); ok( $thing->does('Role::B'), "$name does Role::B" ); ok( $thing->does( Role::A->meta ), "$name does Role::A (passed as object)" ); ok( $thing->does( Role::B->meta ), "$name does Role::B (passed as object)" ); ok( $thing->DOES('Role::A'), "$name does Role::A (using DOES)" ); ok( $thing->DOES('Role::B'), "$name does Role::B (using DOES)" ); } } qw( Foo Bar Baz Foo::Child Bar::Child Baz::Child ); done_testing; add_method_modifier.t100644000767000024 752712200352344 17703 0ustar00etherstaff000000000000Moose-2.1005/t/cmopuse strict; use warnings; use Test::More; use Test::Fatal; use Class::MOP; { package BankAccount; use strict; use warnings; use metaclass; use Carp 'confess'; BankAccount->meta->add_attribute( 'balance' => ( accessor => 'balance', init_arg => 'balance', default => 0 ) ); sub new { (shift)->meta->new_object(@_) } sub deposit { my ( $self, $amount ) = @_; $self->balance( $self->balance + $amount ); } sub withdraw { my ( $self, $amount ) = @_; my $current_balance = $self->balance(); ( $current_balance >= $amount ) || confess "Account overdrawn"; $self->balance( $current_balance - $amount ); } package CheckingAccount; use strict; use warnings; use metaclass; use base 'BankAccount'; CheckingAccount->meta->add_attribute( 'overdraft_account' => ( accessor => 'overdraft_account', init_arg => 'overdraft', ) ); CheckingAccount->meta->add_before_method_modifier( 'withdraw' => sub { my ( $self, $amount ) = @_; my $overdraft_amount = $amount - $self->balance(); if ( $overdraft_amount > 0 ) { $self->overdraft_account->withdraw($overdraft_amount); $self->deposit($overdraft_amount); } } ); ::like( ::exception{ CheckingAccount->meta->add_before_method_modifier( 'does_not_exist' => sub { } ); }, qr/\QThe method 'does_not_exist' was not found in the inheritance hierarchy for CheckingAccount/ ); ::ok( CheckingAccount->meta->has_method('withdraw'), '... checking account now has a withdraw method' ); ::isa_ok( CheckingAccount->meta->get_method('withdraw'), 'Class::MOP::Method::Wrapped' ); ::isa_ok( BankAccount->meta->get_method('withdraw'), 'Class::MOP::Method' ); CheckingAccount->meta->add_method( foo => sub { 'foo' } ); CheckingAccount->meta->add_before_method_modifier( foo => sub { 'wrapped' } ); ::isa_ok( CheckingAccount->meta->get_method('foo'), 'Class::MOP::Method::Wrapped' ); } my $savings_account = BankAccount->new( balance => 250 ); isa_ok( $savings_account, 'BankAccount' ); is( $savings_account->balance, 250, '... got the right savings balance' ); is( exception { $savings_account->withdraw(50); }, undef, '... withdrew from savings successfully' ); is( $savings_account->balance, 200, '... got the right savings balance after withdrawal' ); isnt( exception { $savings_account->withdraw(250); }, undef, '... could not withdraw from savings successfully' ); $savings_account->deposit(150); is( $savings_account->balance, 350, '... got the right savings balance after deposit' ); my $checking_account = CheckingAccount->new( balance => 100, overdraft => $savings_account ); isa_ok( $checking_account, 'CheckingAccount' ); isa_ok( $checking_account, 'BankAccount' ); is( $checking_account->overdraft_account, $savings_account, '... got the right overdraft account' ); is( $checking_account->balance, 100, '... got the right checkings balance' ); is( exception { $checking_account->withdraw(50); }, undef, '... withdrew from checking successfully' ); is( $checking_account->balance, 50, '... got the right checkings balance after withdrawal' ); is( $savings_account->balance, 350, '... got the right savings balance after checking withdrawal (no overdraft)' ); is( exception { $checking_account->withdraw(200); }, undef, '... withdrew from checking successfully' ); is( $checking_account->balance, 0, '... got the right checkings balance after withdrawal' ); is( $savings_account->balance, 200, '... got the right savings balance after overdraft withdrawal' ); done_testing; immutable_metaclass.t100644000767000024 2314412200352344 17761 0ustar00etherstaff000000000000Moose-2.1005/t/cmopuse strict; use warnings; use Test::More; use Test::Fatal; use Class::MOP; { package Foo; use strict; use warnings; use metaclass; __PACKAGE__->meta->add_attribute('bar'); package Bar; use strict; use warnings; use metaclass; __PACKAGE__->meta->superclasses('Foo'); __PACKAGE__->meta->add_attribute('baz'); package Baz; use strict; use warnings; use metaclass; __PACKAGE__->meta->superclasses('Bar'); __PACKAGE__->meta->add_attribute('bah'); } { my $meta = Foo->meta; my $original_metaclass_name = ref $meta; is_deeply( { $meta->immutable_options }, {}, 'immutable_options is empty before a class is made_immutable' ); ok( $meta->make_immutable, 'make_immutable returns true' ); my $line = __LINE__ - 1; ok( $meta->make_immutable, 'make_immutable still returns true' ); my $immutable_metaclass = $meta->_immutable_metaclass->meta; my $immutable_class_name = $immutable_metaclass->name; ok( !$immutable_class_name->is_mutable, '... immutable_metaclass is not mutable' ); ok( $immutable_class_name->is_immutable, '... immutable_metaclass is immutable' ); is( $immutable_class_name->meta, $immutable_metaclass, '... immutable_metaclass meta hack works' ); is_deeply( { $meta->immutable_options }, { inline_accessors => 1, inline_constructor => 1, inline_destructor => 0, debug => 0, immutable_trait => 'Class::MOP::Class::Immutable::Trait', constructor_name => 'new', constructor_class => 'Class::MOP::Method::Constructor', destructor_class => undef, file => $0, line => $line, }, 'immutable_options is empty before a class is made_immutable' ); isa_ok( $meta, "Class::MOP::Class" ); } { my $meta = Foo->meta; is( $meta->name, 'Foo', '... checking the Foo metaclass' ); ok( !$meta->is_mutable, '... our class is not mutable' ); ok( $meta->is_immutable, '... our class is immutable' ); isa_ok( $meta, 'Class::MOP::Class' ); isnt( exception { $meta->add_method() }, undef, '... exception thrown as expected' ); isnt( exception { $meta->alias_method() }, undef, '... exception thrown as expected' ); isnt( exception { $meta->remove_method() }, undef, '... exception thrown as expected' ); isnt( exception { $meta->add_attribute() }, undef, '... exception thrown as expected' ); isnt( exception { $meta->remove_attribute() }, undef, '... exception thrown as expected' ); isnt( exception { $meta->add_package_symbol() }, undef, '... exception thrown as expected' ); isnt( exception { $meta->remove_package_symbol() }, undef, '... exception thrown as expected' ); is( exception { $meta->identifier() }, undef, '... no exception for get_package_symbol special case' ); my @supers; is( exception { @supers = $meta->superclasses; }, undef, '... got the superclasses okay' ); isnt( exception { $meta->superclasses( ['UNIVERSAL'] ) }, undef, '... but could not set the superclasses okay' ); my $meta_instance; is( exception { $meta_instance = $meta->get_meta_instance; }, undef, '... got the meta instance okay' ); isa_ok( $meta_instance, 'Class::MOP::Instance' ); is( $meta_instance, $meta->get_meta_instance, '... and we know it is cached' ); my @cpl; is( exception { @cpl = $meta->class_precedence_list; }, undef, '... got the class precedence list okay' ); is_deeply( \@cpl, ['Foo'], '... we just have ourselves in the class precedence list' ); my @attributes; is( exception { @attributes = $meta->get_all_attributes; }, undef, '... got the attribute list okay' ); is_deeply( \@attributes, [ $meta->get_attribute('bar') ], '... got the right list of attributes' ); } { my $meta = Bar->meta; is( $meta->name, 'Bar', '... checking the Bar metaclass' ); ok( $meta->is_mutable, '... our class is mutable' ); ok( !$meta->is_immutable, '... our class is not immutable' ); is( exception { $meta->make_immutable(); }, undef, '... changed Bar to be immutable' ); ok( $meta->make_immutable, '... make immutable returns true' ); ok( !$meta->is_mutable, '... our class is no longer mutable' ); ok( $meta->is_immutable, '... our class is now immutable' ); isa_ok( $meta, 'Class::MOP::Class' ); isnt( exception { $meta->add_method() }, undef, '... exception thrown as expected' ); isnt( exception { $meta->alias_method() }, undef, '... exception thrown as expected' ); isnt( exception { $meta->remove_method() }, undef, '... exception thrown as expected' ); isnt( exception { $meta->add_attribute() }, undef, '... exception thrown as expected' ); isnt( exception { $meta->remove_attribute() }, undef, '... exception thrown as expected' ); isnt( exception { $meta->add_package_symbol() }, undef, '... exception thrown as expected' ); isnt( exception { $meta->remove_package_symbol() }, undef, '... exception thrown as expected' ); my @supers; is( exception { @supers = $meta->superclasses; }, undef, '... got the superclasses okay' ); isnt( exception { $meta->superclasses( ['UNIVERSAL'] ) }, undef, '... but could not set the superclasses okay' ); my $meta_instance; is( exception { $meta_instance = $meta->get_meta_instance; }, undef, '... got the meta instance okay' ); isa_ok( $meta_instance, 'Class::MOP::Instance' ); is( $meta_instance, $meta->get_meta_instance, '... and we know it is cached' ); my @cpl; is( exception { @cpl = $meta->class_precedence_list; }, undef, '... got the class precedence list okay' ); is_deeply( \@cpl, [ 'Bar', 'Foo' ], '... we just have ourselves in the class precedence list' ); my @attributes; is( exception { @attributes = $meta->get_all_attributes; }, undef, '... got the attribute list okay' ); is_deeply( [ sort { $a->name cmp $b->name } @attributes ], [ Foo->meta->get_attribute('bar'), $meta->get_attribute('baz') ], '... got the right list of attributes' ); } { my $meta = Baz->meta; is( $meta->name, 'Baz', '... checking the Baz metaclass' ); ok( $meta->is_mutable, '... our class is mutable' ); ok( !$meta->is_immutable, '... our class is not immutable' ); is( exception { $meta->make_immutable(); }, undef, '... changed Baz to be immutable' ); ok( $meta->make_immutable, '... make immutable returns true' ); ok( !$meta->is_mutable, '... our class is no longer mutable' ); ok( $meta->is_immutable, '... our class is now immutable' ); isa_ok( $meta, 'Class::MOP::Class' ); isnt( exception { $meta->add_method() }, undef, '... exception thrown as expected' ); isnt( exception { $meta->alias_method() }, undef, '... exception thrown as expected' ); isnt( exception { $meta->remove_method() }, undef, '... exception thrown as expected' ); isnt( exception { $meta->add_attribute() }, undef, '... exception thrown as expected' ); isnt( exception { $meta->remove_attribute() }, undef, '... exception thrown as expected' ); isnt( exception { $meta->add_package_symbol() }, undef, '... exception thrown as expected' ); isnt( exception { $meta->remove_package_symbol() }, undef, '... exception thrown as expected' ); my @supers; is( exception { @supers = $meta->superclasses; }, undef, '... got the superclasses okay' ); isnt( exception { $meta->superclasses( ['UNIVERSAL'] ) }, undef, '... but could not set the superclasses okay' ); my $meta_instance; is( exception { $meta_instance = $meta->get_meta_instance; }, undef, '... got the meta instance okay' ); isa_ok( $meta_instance, 'Class::MOP::Instance' ); is( $meta_instance, $meta->get_meta_instance, '... and we know it is cached' ); my @cpl; is( exception { @cpl = $meta->class_precedence_list; }, undef, '... got the class precedence list okay' ); is_deeply( \@cpl, [ 'Baz', 'Bar', 'Foo' ], '... we just have ourselves in the class precedence list' ); my @attributes; is( exception { @attributes = $meta->get_all_attributes; }, undef, '... got the attribute list okay' ); is_deeply( [ sort { $a->name cmp $b->name } @attributes ], [ $meta->get_attribute('bah'), Foo->meta->get_attribute('bar'), Bar->meta->get_attribute('baz') ], '... got the right list of attributes' ); } # This test probably needs to go last since it will muck up the Foo class { my $meta = Foo->meta; $meta->make_mutable; $meta->make_immutable( inline_accessors => 0, inline_constructor => 0, constructor_name => 'newer', ); my $line = __LINE__ - 5; is_deeply( { $meta->immutable_options }, { inline_accessors => 0, inline_constructor => 0, inline_destructor => 0, debug => 0, immutable_trait => 'Class::MOP::Class::Immutable::Trait', constructor_name => 'newer', constructor_class => 'Class::MOP::Method::Constructor', destructor_class => undef, file => $0, line => $line, }, 'custom immutable_options are returned by immutable_options accessor' ); } done_testing; InsideOutClass_test.t100644000767000024 1557312200352344 17705 0ustar00etherstaff000000000000Moose-2.1005/t/cmopuse strict; use warnings; use Test::More; use File::Spec; use Scalar::Util 'reftype'; BEGIN {use Class::MOP; require_ok(File::Spec->catfile('examples', 'InsideOutClass.pod')); } { package Foo; use strict; use warnings; use metaclass ( 'attribute_metaclass' => 'InsideOutClass::Attribute', 'instance_metaclass' => 'InsideOutClass::Instance' ); Foo->meta->add_attribute('foo' => ( accessor => 'foo', predicate => 'has_foo', )); Foo->meta->add_attribute('bar' => ( reader => 'get_bar', writer => 'set_bar', default => 'FOO is BAR' )); sub new { my $class = shift; $class->meta->new_object(@_); } package Bar; use metaclass ( 'attribute_metaclass' => 'InsideOutClass::Attribute', 'instance_metaclass' => 'InsideOutClass::Instance' ); use strict; use warnings; use base 'Foo'; Bar->meta->add_attribute('baz' => ( accessor => 'baz', predicate => 'has_baz', )); package Baz; use strict; use warnings; use metaclass ( 'attribute_metaclass' => 'InsideOutClass::Attribute', 'instance_metaclass' => 'InsideOutClass::Instance' ); Baz->meta->add_attribute('bling' => ( accessor => 'bling', default => 'Baz::bling' )); package Bar::Baz; use metaclass ( 'attribute_metaclass' => 'InsideOutClass::Attribute', 'instance_metaclass' => 'InsideOutClass::Instance' ); use strict; use warnings; use base 'Bar', 'Baz'; } my $foo = Foo->new(); isa_ok($foo, 'Foo'); is(reftype($foo), 'SCALAR', '... Foo is made with SCALAR'); can_ok($foo, 'foo'); can_ok($foo, 'has_foo'); can_ok($foo, 'get_bar'); can_ok($foo, 'set_bar'); ok(!$foo->has_foo, '... Foo::foo is not defined yet'); is($foo->foo(), undef, '... Foo::foo is not defined yet'); is($foo->get_bar(), 'FOO is BAR', '... Foo::bar has been initialized'); $foo->foo('This is Foo'); ok($foo->has_foo, '... Foo::foo is defined now'); is($foo->foo(), 'This is Foo', '... Foo::foo == "This is Foo"'); $foo->set_bar(42); is($foo->get_bar(), 42, '... Foo::bar == 42'); my $foo2 = Foo->new(); isa_ok($foo2, 'Foo'); is(reftype($foo2), 'SCALAR', '... Foo is made with SCALAR'); ok(!$foo2->has_foo, '... Foo2::foo is not defined yet'); is($foo2->foo(), undef, '... Foo2::foo is not defined yet'); is($foo2->get_bar(), 'FOO is BAR', '... Foo2::bar has been initialized'); $foo2->set_bar('DONT PANIC'); is($foo2->get_bar(), 'DONT PANIC', '... Foo2::bar == DONT PANIC'); is($foo->get_bar(), 42, '... Foo::bar == 42'); # now Bar ... my $bar = Bar->new(); isa_ok($bar, 'Bar'); isa_ok($bar, 'Foo'); is(reftype($bar), 'SCALAR', '... Bar is made with SCALAR'); can_ok($bar, 'foo'); can_ok($bar, 'has_foo'); can_ok($bar, 'get_bar'); can_ok($bar, 'set_bar'); can_ok($bar, 'baz'); can_ok($bar, 'has_baz'); ok(!$bar->has_foo, '... Bar::foo is not defined yet'); is($bar->foo(), undef, '... Bar::foo is not defined yet'); is($bar->get_bar(), 'FOO is BAR', '... Bar::bar has been initialized'); ok(!$bar->has_baz, '... Bar::baz is not defined yet'); is($bar->baz(), undef, '... Bar::baz is not defined yet'); $bar->foo('This is Bar::foo'); ok($bar->has_foo, '... Bar::foo is defined now'); is($bar->foo(), 'This is Bar::foo', '... Bar::foo == "This is Bar"'); is($bar->get_bar(), 'FOO is BAR', '... Bar::bar has been initialized'); $bar->baz('This is Bar::baz'); ok($bar->has_baz, '... Bar::baz is defined now'); is($bar->baz(), 'This is Bar::baz', '... Bar::foo == "This is Bar"'); is($bar->foo(), 'This is Bar::foo', '... Bar::foo == "This is Bar"'); is($bar->get_bar(), 'FOO is BAR', '... Bar::bar has been initialized'); # now Baz ... my $baz = Bar::Baz->new(); isa_ok($baz, 'Bar::Baz'); isa_ok($baz, 'Bar'); isa_ok($baz, 'Foo'); isa_ok($baz, 'Baz'); is(reftype($baz), 'SCALAR', '... Bar::Baz is made with SCALAR'); can_ok($baz, 'foo'); can_ok($baz, 'has_foo'); can_ok($baz, 'get_bar'); can_ok($baz, 'set_bar'); can_ok($baz, 'baz'); can_ok($baz, 'has_baz'); can_ok($baz, 'bling'); is($baz->get_bar(), 'FOO is BAR', '... Bar::Baz::bar has been initialized'); is($baz->bling(), 'Baz::bling', '... Bar::Baz::bling has been initialized'); ok(!$baz->has_foo, '... Bar::Baz::foo is not defined yet'); is($baz->foo(), undef, '... Bar::Baz::foo is not defined yet'); ok(!$baz->has_baz, '... Bar::Baz::baz is not defined yet'); is($baz->baz(), undef, '... Bar::Baz::baz is not defined yet'); $baz->foo('This is Bar::Baz::foo'); ok($baz->has_foo, '... Bar::Baz::foo is defined now'); is($baz->foo(), 'This is Bar::Baz::foo', '... Bar::Baz::foo == "This is Bar"'); is($baz->get_bar(), 'FOO is BAR', '... Bar::Baz::bar has been initialized'); is($baz->bling(), 'Baz::bling', '... Bar::Baz::bling has been initialized'); $baz->baz('This is Bar::Baz::baz'); ok($baz->has_baz, '... Bar::Baz::baz is defined now'); is($baz->baz(), 'This is Bar::Baz::baz', '... Bar::Baz::foo == "This is Bar"'); is($baz->foo(), 'This is Bar::Baz::foo', '... Bar::Baz::foo == "This is Bar"'); is($baz->get_bar(), 'FOO is BAR', '... Bar::Baz::bar has been initialized'); is($baz->bling(), 'Baz::bling', '... Bar::Baz::bling has been initialized'); { no strict 'refs'; ok(*{'Foo::foo'}{HASH}, '... there is a foo package variable in Foo'); ok(*{'Foo::bar'}{HASH}, '... there is a bar package variable in Foo'); is(scalar(keys(%{'Foo::foo'})), 4, '... got the right number of entries for Foo::foo'); is(scalar(keys(%{'Foo::bar'})), 4, '... got the right number of entries for Foo::bar'); ok(!*{'Bar::foo'}{HASH}, '... no foo package variable in Bar'); ok(!*{'Bar::bar'}{HASH}, '... no bar package variable in Bar'); ok(*{'Bar::baz'}{HASH}, '... there is a baz package variable in Bar'); is(scalar(keys(%{'Bar::foo'})), 0, '... got the right number of entries for Bar::foo'); is(scalar(keys(%{'Bar::bar'})), 0, '... got the right number of entries for Bar::bar'); is(scalar(keys(%{'Bar::baz'})), 2, '... got the right number of entries for Bar::baz'); ok(*{'Baz::bling'}{HASH}, '... there is a bar package variable in Baz'); is(scalar(keys(%{'Baz::bling'})), 1, '... got the right number of entries for Baz::bling'); ok(!*{'Bar::Baz::foo'}{HASH}, '... no foo package variable in Bar::Baz'); ok(!*{'Bar::Baz::bar'}{HASH}, '... no bar package variable in Bar::Baz'); ok(!*{'Bar::Baz::baz'}{HASH}, '... no baz package variable in Bar::Baz'); ok(!*{'Bar::Baz::bling'}{HASH}, '... no bar package variable in Baz::Baz'); is(scalar(keys(%{'Bar::Baz::foo'})), 0, '... got the right number of entries for Bar::Baz::foo'); is(scalar(keys(%{'Bar::Baz::bar'})), 0, '... got the right number of entries for Bar::Baz::bar'); is(scalar(keys(%{'Bar::Baz::baz'})), 0, '... got the right number of entries for Bar::Baz::baz'); is(scalar(keys(%{'Bar::Baz::bling'})), 0, '... got the right number of entries for Bar::Baz::bling'); } done_testing; Perl6Attribute_test.t100644000767000024 142512200352344 17637 0ustar00etherstaff000000000000Moose-2.1005/t/cmopuse strict; use warnings; use Test::More; use File::Spec; use Class::MOP; BEGIN { require_ok(File::Spec->catfile('examples', 'Perl6Attribute.pod')); } { package Foo; use metaclass; Foo->meta->add_attribute(Perl6Attribute->new('$.foo')); Foo->meta->add_attribute(Perl6Attribute->new('@.bar')); Foo->meta->add_attribute(Perl6Attribute->new('%.baz')); sub new { my $class = shift; $class->meta->new_object(@_); } } my $foo = Foo->new(); isa_ok($foo, 'Foo'); can_ok($foo, 'foo'); can_ok($foo, 'bar'); can_ok($foo, 'baz'); is($foo->foo, undef, '... Foo.foo == undef'); $foo->foo(42); is($foo->foo, 42, '... Foo.foo == 42'); is_deeply($foo->bar, [], '... Foo.bar == []'); is_deeply($foo->baz, {}, '... Foo.baz == {}'); done_testing; default_values.t100644000767000024 432712200352344 17754 0ustar00etherstaff000000000000Moose-2.1005/t/immutable#!/usr/bin/perl use strict; use warnings; use Test::More; use Test::Fatal; { package Foo; use Moose; has 'foo' => ( is => 'rw', default => q{'} ); has 'bar' => ( is => 'rw', default => q{\\} ); has 'baz' => ( is => 'rw', default => q{"} ); has 'buz' => ( is => 'rw', default => q{"'\\} ); has 'faz' => ( is => 'rw', default => qq{\0} ); ::is( ::exception { __PACKAGE__->meta->make_immutable }, undef, 'no errors making a package immutable when it has default values that could break quoting' ); } my $foo = Foo->new; is( $foo->foo, q{'}, 'default value for foo attr' ); is( $foo->bar, q{\\}, 'default value for bar attr' ); is( $foo->baz, q{"}, 'default value for baz attr' ); is( $foo->buz, q{"'\\}, 'default value for buz attr' ); is( $foo->faz, qq{\0}, 'default value for faz attr' ); # Lazy attrs were never broken, but it doesn't hurt to test that they # won't be broken by any future changes. # Also make sure that attributes stay lazy even after being immutable { package Bar; use Moose; has 'foo' => ( is => 'rw', default => q{'}, lazy => 1 ); has 'bar' => ( is => 'rw', default => q{\\}, lazy => 1 ); has 'baz' => ( is => 'rw', default => q{"}, lazy => 1 ); has 'buz' => ( is => 'rw', default => q{"'\\}, lazy => 1 ); has 'faz' => ( is => 'rw', default => qq{\0}, lazy => 1 ); { my $bar = Bar->new; ::ok(!$bar->meta->get_attribute($_)->has_value($bar), "Attribute $_ has no value") for qw(foo bar baz buz faz); } ::is( ::exception { __PACKAGE__->meta->make_immutable }, undef, 'no errors making a package immutable when it has lazy default values that could break quoting' ); { my $bar = Bar->new; ::ok(!$bar->meta->get_attribute($_)->has_value($bar), "Attribute $_ has no value (immutable)") for(qw(foo bar baz buz faz)); } } my $bar = Bar->new; is( $bar->foo, q{'}, 'default value for foo attr' ); is( $bar->bar, q{\\}, 'default value for bar attr' ); is( $bar->baz, q{"}, 'default value for baz attr' ); is( $bar->buz, q{"'\\}, 'default value for buz attr' ); is( $bar->faz, qq{\0}, 'default value for faz attr' ); done_testing; reinitialize.t100644000767000024 2232712200352344 20006 0ustar00etherstaff000000000000Moose-2.1005/t/metaclasses#!/usr/bin/env perl use strict; use warnings; use Test::More; use Test::Moose; use Test::Fatal; sub check_meta_sanity { my ($meta, $class) = @_; local $Test::Builder::Level = $Test::Builder::Level + 1; isa_ok($meta, 'Moose::Meta::Class'); is($meta->name, $class); ok($meta->has_method('foo')); isa_ok($meta->get_method('foo'), 'Moose::Meta::Method'); ok($meta->has_attribute('bar')); isa_ok($meta->get_attribute('bar'), 'Moose::Meta::Attribute'); if ( $meta->name eq 'Foo' ) { ok($meta->does_role('Role1'), 'does Role1'); ok($meta->does_role('Role2'), 'does Role2'); is_deeply( [ map { [ $_->role->name, $_->class->name ] } sort { $a->role->name cmp $b->role->name } $meta->role_applications ], [ [ 'Role1|Role2', 'Foo' ], ], 'role applications for Role1 and Role2' ); } } { package Role1; use Moose::Role; } { package Role2; use Moose::Role; } { package Foo; use Moose; sub foo {} with 'Role1', 'Role2'; has bar => (is => 'ro'); } check_meta_sanity(Foo->meta, 'Foo'); Moose::Meta::Class->reinitialize('Foo'); check_meta_sanity(Foo->meta, 'Foo'); { package Foo::Role::Method; use Moose::Role; has foo => (is => 'rw'); } { package Foo::Role::Attribute; use Moose::Role; has oof => (is => 'rw'); } Moose::Util::MetaRole::apply_metaroles( for => 'Foo', class_metaroles => { method => ['Foo::Role::Method'], attribute => ['Foo::Role::Attribute'], }, ); check_meta_sanity(Foo->meta, 'Foo'); does_ok(Foo->meta->get_method('foo'), 'Foo::Role::Method'); does_ok(Foo->meta->get_attribute('bar'), 'Foo::Role::Attribute'); Moose::Meta::Class->reinitialize('Foo'); check_meta_sanity(Foo->meta, 'Foo'); does_ok(Foo->meta->get_method('foo'), 'Foo::Role::Method'); does_ok(Foo->meta->get_attribute('bar'), 'Foo::Role::Attribute'); Foo->meta->get_method('foo')->foo('TEST'); Foo->meta->get_attribute('bar')->oof('TSET'); is(Foo->meta->get_method('foo')->foo, 'TEST'); is(Foo->meta->get_attribute('bar')->oof, 'TSET'); Moose::Meta::Class->reinitialize('Foo'); check_meta_sanity(Foo->meta, 'Foo'); is(Foo->meta->get_method('foo')->foo, 'TEST'); is(Foo->meta->get_attribute('bar')->oof, 'TSET'); { package Bar::Role::Method; use Moose::Role; } { package Bar::Role::Attribute; use Moose::Role; } { package Bar; use Moose; Moose::Util::MetaRole::apply_metaroles( for => 'Bar', class_metaroles => { method => ['Bar::Role::Method'], attribute => ['Bar::Role::Attribute'], }, ); sub foo {} has bar => (is => 'ro'); } check_meta_sanity(Bar->meta, 'Bar'); does_ok(Bar->meta->get_method('foo'), 'Bar::Role::Method'); does_ok(Bar->meta->get_attribute('bar'), 'Bar::Role::Attribute'); Moose::Meta::Class->reinitialize('Bar'); check_meta_sanity(Bar->meta, 'Bar'); does_ok(Bar->meta->get_method('foo'), 'Bar::Role::Method'); does_ok(Bar->meta->get_attribute('bar'), 'Bar::Role::Attribute'); ok(!Moose::Util::does_role(Bar->meta->get_method('foo'), 'Foo::Role::Method')); ok(!Moose::Util::does_role(Bar->meta->get_attribute('bar'), 'Foo::Role::Attribute')); Moose::Util::MetaRole::apply_metaroles( for => 'Bar', class_metaroles => { method => ['Foo::Role::Method'], attribute => ['Foo::Role::Attribute'], }, ); check_meta_sanity(Bar->meta, 'Bar'); does_ok(Bar->meta->get_method('foo'), 'Bar::Role::Method'); does_ok(Bar->meta->get_attribute('bar'), 'Bar::Role::Attribute'); does_ok(Bar->meta->get_method('foo'), 'Foo::Role::Method'); does_ok(Bar->meta->get_attribute('bar'), 'Foo::Role::Attribute'); { package Bar::Meta::Method; use Moose; BEGIN { extends 'Moose::Meta::Method' }; } { package Bar::Meta::Attribute; use Moose; BEGIN { extends 'Moose::Meta::Attribute' }; } like( exception { Moose::Meta::Class->reinitialize( 'Bar', method_metaclass => 'Bar::Meta::Method', attribute_metaclass => 'Bar::Meta::Attribute', ); }, qr/compatible/ ); { package Baz::Meta::Class; use Moose; BEGIN { extends 'Moose::Meta::Class' }; sub initialize { my $self = shift; return $self->SUPER::initialize( @_, method_metaclass => 'Bar::Meta::Method', attribute_metaclass => 'Bar::Meta::Attribute' ); } } { package Baz; use Moose -metaclass => 'Baz::Meta::Class'; sub foo {} has bar => (is => 'ro'); } check_meta_sanity(Baz->meta, 'Baz'); isa_ok(Baz->meta->get_method('foo'), 'Bar::Meta::Method'); isa_ok(Baz->meta->get_attribute('bar'), 'Bar::Meta::Attribute'); Moose::Meta::Class->reinitialize('Baz'); check_meta_sanity(Baz->meta, 'Baz'); isa_ok(Baz->meta->get_method('foo'), 'Bar::Meta::Method'); isa_ok(Baz->meta->get_attribute('bar'), 'Bar::Meta::Attribute'); Moose::Util::MetaRole::apply_metaroles( for => 'Baz', class_metaroles => { method => ['Foo::Role::Method'], attribute => ['Foo::Role::Attribute'], }, ); check_meta_sanity(Baz->meta, 'Baz'); isa_ok(Baz->meta->get_method('foo'), 'Bar::Meta::Method'); isa_ok(Baz->meta->get_attribute('bar'), 'Bar::Meta::Attribute'); does_ok(Baz->meta->get_method('foo'), 'Foo::Role::Method'); does_ok(Baz->meta->get_attribute('bar'), 'Foo::Role::Attribute'); { package Baz::Meta::Method; use Moose; extends 'Moose::Meta::Method'; } { package Baz::Meta::Attribute; use Moose; extends 'Moose::Meta::Attribute'; } like( exception { Moose::Meta::Class->reinitialize( 'Baz', method_metaclass => 'Baz::Meta::Method', attribute_metaclass => 'Baz::Meta::Attribute', ); }, qr/compatible/ ); { package Quux; use Moose; sub foo { } before foo => sub { }; has bar => (is => 'ro'); sub DEMOLISH { } __PACKAGE__->meta->make_immutable; } ok(Quux->meta->has_method('new')); isa_ok(Quux->meta->get_method('new'), 'Moose::Meta::Method::Constructor'); ok(Quux->meta->has_method('meta')); isa_ok(Quux->meta->get_method('meta'), 'Moose::Meta::Method::Meta'); ok(Quux->meta->has_method('foo')); isa_ok(Quux->meta->get_method('foo'), 'Class::MOP::Method::Wrapped'); ok(Quux->meta->has_method('bar')); isa_ok(Quux->meta->get_method('bar'), 'Moose::Meta::Method::Accessor'); ok(Quux->meta->has_method('DESTROY')); isa_ok(Quux->meta->get_method('DESTROY'), 'Moose::Meta::Method::Destructor'); ok(Quux->meta->has_method('DEMOLISH')); isa_ok(Quux->meta->get_method('DEMOLISH'), 'Moose::Meta::Method'); Quux->meta->make_mutable; Moose::Meta::Class->reinitialize('Quux'); Quux->meta->make_immutable; ok(Quux->meta->has_method('new')); isa_ok(Quux->meta->get_method('new'), 'Moose::Meta::Method::Constructor'); ok(Quux->meta->has_method('meta')); isa_ok(Quux->meta->get_method('meta'), 'Moose::Meta::Method::Meta'); ok(Quux->meta->has_method('foo')); isa_ok(Quux->meta->get_method('foo'), 'Class::MOP::Method::Wrapped'); ok(Quux->meta->has_method('bar')); isa_ok(Quux->meta->get_method('bar'), 'Moose::Meta::Method::Accessor'); ok(Quux->meta->has_method('DESTROY')); isa_ok(Quux->meta->get_method('DESTROY'), 'Moose::Meta::Method::Destructor'); ok(Quux->meta->has_method('DEMOLISH')); isa_ok(Quux->meta->get_method('DEMOLISH'), 'Moose::Meta::Method'); Quux->meta->make_mutable; Moose::Util::MetaRole::apply_metaroles( for => 'Quux', class_metaroles => { method => ['Foo::Role::Method'], attribute => ['Foo::Role::Attribute'], }, ); Quux->meta->make_immutable; ok(Quux->meta->has_method('new')); isa_ok(Quux->meta->get_method('new'), 'Moose::Meta::Method::Constructor'); { local $TODO = "constructor methods don't get metaroles yet"; does_ok(Quux->meta->get_method('new'), 'Foo::Role::Method'); } ok(Quux->meta->has_method('meta')); isa_ok(Quux->meta->get_method('meta'), 'Moose::Meta::Method::Meta'); { local $TODO = "meta methods don't get metaroles yet"; does_ok(Quux->meta->get_method('meta'), 'Foo::Role::Method'); } ok(Quux->meta->has_method('foo')); isa_ok(Quux->meta->get_method('foo'), 'Class::MOP::Method::Wrapped'); { local $TODO = "modified methods don't get metaroles yet"; does_ok(Quux->meta->get_method('foo'), 'Foo::Role::Method'); } ok(Quux->meta->has_method('bar')); isa_ok(Quux->meta->get_method('bar'), 'Moose::Meta::Method::Accessor'); { local $TODO = "accessor methods don't get metaroles yet"; does_ok(Quux->meta->get_method('bar'), 'Foo::Role::Method'); } ok(Quux->meta->has_method('DESTROY')); isa_ok(Quux->meta->get_method('DESTROY'), 'Moose::Meta::Method::Destructor'); { local $TODO = "destructor methods don't get metaroles yet"; does_ok(Quux->meta->get_method('DESTROY'), 'Foo::Role::Method'); } ok(Quux->meta->has_method('DEMOLISH')); isa_ok(Quux->meta->get_method('DEMOLISH'), 'Moose::Meta::Method'); does_ok(Quux->meta->get_method('DEMOLISH'), 'Foo::Role::Method'); { package Role3; use Moose::Role; with 'Role1', 'Role2'; } ok( Role3->meta->does_role('Role1'), 'Role3 does Role1' ); ok( Role3->meta->does_role('Role2'), 'Role3 does Role2' ); Moose::Meta::Role->reinitialize('Role3'); ok( Role3->meta->does_role('Role1'), 'Role3 does Role1 after reinitialize' ); ok( Role3->meta->does_role('Role2'), 'Role3 does Role2 after reinitialize' ); done_testing; resolve_alias.t100644000767000024 675012200352344 20003 0ustar00etherstaff000000000000Moose-2.1005/t/moose_util#!/usr/bin/perl use strict; use warnings; use Test::More; use Moose::Util qw( resolve_metaclass_alias resolve_metatrait_alias ); use lib 't/lib'; # Doing each test twice is intended to make sure that the caching # doesn't break name resolution. It doesn't actually test that # anything is cached. is( resolve_metaclass_alias( 'Attribute', 'Moose::Meta::Attribute::Custom::Foo' ), 'Moose::Meta::Attribute::Custom::Foo', 'resolve_metaclass_alias finds Moose::Meta::Attribute::Custom::Foo' ); is( resolve_metaclass_alias( 'Attribute', 'Moose::Meta::Attribute::Custom::Foo' ), 'Moose::Meta::Attribute::Custom::Foo', 'resolve_metaclass_alias finds Moose::Meta::Attribute::Custom::Foo second time' ); is( resolve_metaclass_alias( 'Attribute', 'Foo' ), 'Moose::Meta::Attribute::Custom::Foo', 'resolve_metaclass_alias finds Moose::Meta::Attribute::Custom::Foo via alias (Foo)' ); is( resolve_metaclass_alias( 'Attribute', 'Foo' ), 'Moose::Meta::Attribute::Custom::Foo', 'resolve_metaclass_alias finds Moose::Meta::Attribute::Custom::Foo via alias (Foo) a second time' ); is( resolve_metaclass_alias( 'Attribute', 'Moose::Meta::Attribute::Custom::Bar' ), 'My::Bar', 'resolve_metaclass_alias finds Moose::Meta::Attribute::Custom::Bar as My::Bar' ); is( resolve_metaclass_alias( 'Attribute', 'Moose::Meta::Attribute::Custom::Bar' ), 'My::Bar', 'resolve_metaclass_alias finds Moose::Meta::Attribute::Custom::Bar as My::Bar a second time' ); is( resolve_metaclass_alias( 'Attribute', 'Bar' ), 'My::Bar', 'resolve_metaclass_alias finds Moose::Meta::Attribute::Custom::Bar as My::Bar via alias (Bar)' ); is( resolve_metaclass_alias( 'Attribute', 'Bar' ), 'My::Bar', 'resolve_metaclass_alias finds Moose::Meta::Attribute::Custom::Bar as My::Bar via alias (Bar) a second time' ); is( resolve_metatrait_alias( 'Attribute', 'Moose::Meta::Attribute::Custom::Trait::Foo' ), 'Moose::Meta::Attribute::Custom::Trait::Foo', 'resolve_metatrait_alias finds Moose::Meta::Attribute::Custom::Trait::Foo' ); is( resolve_metatrait_alias( 'Attribute', 'Moose::Meta::Attribute::Custom::Trait::Foo' ), 'Moose::Meta::Attribute::Custom::Trait::Foo', 'resolve_metatrait_alias finds Moose::Meta::Attribute::Custom::Trait::Foo second time' ); is( resolve_metatrait_alias( 'Attribute', 'Foo' ), 'Moose::Meta::Attribute::Custom::Trait::Foo', 'resolve_metatrait_alias finds Moose::Meta::Attribute::Custom::Trait::Foo via alias (Foo)' ); is( resolve_metatrait_alias( 'Attribute', 'Foo' ), 'Moose::Meta::Attribute::Custom::Trait::Foo', 'resolve_metatrait_alias finds Moose::Meta::Attribute::Custom::Trait::Foo via alias (Foo) a second time' ); is( resolve_metatrait_alias( 'Attribute', 'Moose::Meta::Attribute::Custom::Trait::Bar' ), 'My::Trait::Bar', 'resolve_metatrait_alias finds Moose::Meta::Attribute::Custom::Trait::Bar as My::Trait::Bar' ); is( resolve_metatrait_alias( 'Attribute', 'Moose::Meta::Attribute::Custom::Trait::Bar' ), 'My::Trait::Bar', 'resolve_metatrait_alias finds Moose::Meta::Attribute::Custom::Trait::Bar as My::Trait::Bar a second time' ); is( resolve_metatrait_alias( 'Attribute', 'Bar' ), 'My::Trait::Bar', 'resolve_metatrait_alias finds Moose::Meta::Attribute::Custom::Trait::Bar as My::Trait::Bar via alias (Bar)' ); is( resolve_metatrait_alias( 'Attribute', 'Bar' ), 'My::Trait::Bar', 'resolve_metatrait_alias finds Moose::Meta::Attribute::Custom::Trait::Bar as My::Trait::Bar via alias (Bar) a second time' ); done_testing; native_traits000755000767000024 012200352344 15313 5ustar00etherstaff000000000000Moose-2.1005/ttrait_bool.t100644000767000024 552012200352344 20000 0ustar00etherstaff000000000000Moose-2.1005/t/native_traits#!/usr/bin/perl use strict; use warnings; use lib 't/lib'; use Moose (); use Moose::Util::TypeConstraints; use NoInlineAttribute; use Test::More; use Test::Fatal; use Test::Moose; { my %handles = ( illuminate => 'set', darken => 'unset', flip_switch => 'toggle', is_dark => 'not', ); my $name = 'Foo1'; sub build_class { my %attr = @_; my $class = Moose::Meta::Class->create( $name++, superclasses => ['Moose::Object'], ); my @traits = 'Bool'; push @traits, 'NoInlineAttribute' if delete $attr{no_inline}; $class->add_attribute( is_lit => ( traits => \@traits, is => 'rw', isa => 'Bool', default => 0, handles => \%handles, clearer => '_clear_is_list', %attr, ), ); return ( $class->name, \%handles ); } } { run_tests(build_class); run_tests( build_class( lazy => 1 ) ); run_tests( build_class( trigger => sub { } ) ); run_tests( build_class( no_inline => 1 ) ); # Will force the inlining code to check the entire hashref when it is modified. subtype 'MyBool', as 'Bool', where { 1 }; run_tests( build_class( isa => 'MyBool' ) ); coerce 'MyBool', from 'Bool', via { $_ }; run_tests( build_class( isa => 'MyBool', coerce => 1 ) ); } sub run_tests { my ( $class, $handles ) = @_; can_ok( $class, $_ ) for sort keys %{$handles}; with_immutable { my $obj = $class->new; ok( $obj->illuminate, 'set returns true' ); ok( $obj->is_lit, 'set is_lit to 1 using ->illuminate' ); ok( !$obj->is_dark, 'check if is_dark does the right thing' ); like( exception { $obj->illuminate(1) }, qr/Cannot call set with any arguments/, 'set throws an error when an argument is passed' ); ok( !$obj->darken, 'unset returns false' ); ok( !$obj->is_lit, 'set is_lit to 0 using ->darken' ); ok( $obj->is_dark, 'check if is_dark does the right thing' ); like( exception { $obj->darken(1) }, qr/Cannot call unset with any arguments/, 'unset throws an error when an argument is passed' ); ok( $obj->flip_switch, 'toggle returns new value' ); ok( $obj->is_lit, 'toggle is_lit back to 1 using ->flip_switch' ); ok( !$obj->is_dark, 'check if is_dark does the right thing' ); like( exception { $obj->flip_switch(1) }, qr/Cannot call toggle with any arguments/, 'toggle throws an error when an argument is passed' ); $obj->flip_switch; ok( !$obj->is_lit, 'toggle is_lit back to 0 again using ->flip_switch' ); ok( $obj->is_dark, 'check if is_dark does the right thing' ); } $class; } done_testing; trait_code.t100644000767000024 504412200352344 17760 0ustar00etherstaff000000000000Moose-2.1005/t/native_traitsuse strict; use warnings; use lib 't/lib'; use Moose (); use NoInlineAttribute; use Test::More; use Test::Moose; { my $name = 'Foo1'; sub build_class { my ( $attr1, $attr2, $attr3, $no_inline ) = @_; my $class = Moose::Meta::Class->create( $name++, superclasses => ['Moose::Object'], ); my @traits = 'Code'; push @traits, 'NoInlineAttribute' if $no_inline; $class->add_attribute( callback => ( traits => \@traits, isa => 'CodeRef', required => 1, handles => { 'invoke_callback' => 'execute' }, %{ $attr1 || {} }, ) ); $class->add_attribute( callback_method => ( traits => \@traits, isa => 'CodeRef', required => 1, handles => { 'invoke_method_callback' => 'execute_method' }, %{ $attr2 || {} }, ) ); $class->add_attribute( multiplier => ( traits => \@traits, isa => 'CodeRef', required => 1, handles => { 'multiply' => 'execute' }, %{ $attr3 || {} }, ) ); return $class->name; } } { my $i; my %subs = ( callback => sub { ++$i }, callback_method => sub { shift->multiply(@_) }, multiplier => sub { $_[0] * 2 }, ); run_tests( build_class, \$i, \%subs ); run_tests( build_class( undef, undef, undef, 1 ), \$i, \%subs ); run_tests( build_class( { lazy => 1, default => sub { $subs{callback} } }, { lazy => 1, default => sub { $subs{callback_method} } }, { lazy => 1, default => sub { $subs{multiplier} } }, ), \$i, ); } sub run_tests { my ( $class, $iref, @args ) = @_; ok( !$class->can($_), "Code trait didn't create reader method for $_" ) for qw(callback callback_method multiplier); with_immutable { ${$iref} = 0; my $obj = $class->new(@args); $obj->invoke_callback; is( ${$iref}, 1, '$i is 1 after invoke_callback' ); is( $obj->invoke_method_callback(3), 6, 'invoke_method_callback calls multiply with @_' ); is( $obj->multiply(3), 6, 'multiple double value' ); } $class; } done_testing; trait_hash.t100644000767000024 2205112200352344 20006 0ustar00etherstaff000000000000Moose-2.1005/t/native_traits#!/usr/bin/perl use strict; use warnings; use lib 't/lib'; use Moose (); use Moose::Util::TypeConstraints; use NoInlineAttribute; use Test::Fatal; use Test::More; use Test::Moose; { my %handles = ( option_accessor => 'accessor', quantity => [ accessor => 'quantity' ], clear_options => 'clear', num_options => 'count', delete_option => 'delete', is_defined => 'defined', options_elements => 'elements', has_option => 'exists', get_option => 'get', has_no_options => 'is_empty', keys => 'keys', values => 'values', key_value => 'kv', set_option => 'set', ); my $name = 'Foo1'; sub build_class { my %attr = @_; my $class = Moose::Meta::Class->create( $name++, superclasses => ['Moose::Object'], ); my @traits = 'Hash'; push @traits, 'NoInlineAttribute' if delete $attr{no_inline}; $class->add_attribute( options => ( traits => \@traits, is => 'rw', isa => 'HashRef[Str]', default => sub { {} }, handles => \%handles, clearer => '_clear_options', %attr, ), ); return ( $class->name, \%handles ); } } { run_tests(build_class); run_tests( build_class( lazy => 1, default => sub { { x => 1 } } ) ); run_tests( build_class( trigger => sub { } ) ); run_tests( build_class( no_inline => 1 ) ); # Will force the inlining code to check the entire hashref when it is modified. subtype 'MyHashRef', as 'HashRef[Str]', where { 1 }; run_tests( build_class( isa => 'MyHashRef' ) ); coerce 'MyHashRef', from 'HashRef', via { $_ }; run_tests( build_class( isa => 'MyHashRef', coerce => 1 ) ); } sub run_tests { my ( $class, $handles ) = @_; can_ok( $class, $_ ) for sort keys %{$handles}; with_immutable { my $obj = $class->new( options => {} ); ok( $obj->has_no_options, '... we have no options' ); is( $obj->num_options, 0, '... we have no options' ); is_deeply( $obj->options, {}, '... no options yet' ); ok( !$obj->has_option('foo'), '... we have no foo option' ); is( exception { is( $obj->set_option( foo => 'bar' ), 'bar', 'set return single new value in scalar context' ); }, undef, '... set the option okay' ); like( exception { $obj->set_option( foo => 'bar', 'baz' ) }, qr/You must pass an even number of arguments to set/, 'exception with odd number of arguments' ); like( exception { $obj->set_option( undef, 'bar' ) }, qr/Hash keys passed to set must be defined/, 'exception when using undef as a key' ); ok( $obj->is_defined('foo'), '... foo is defined' ); ok( !$obj->has_no_options, '... we have options' ); is( $obj->num_options, 1, '... we have 1 option(s)' ); ok( $obj->has_option('foo'), '... we have a foo option' ); is_deeply( $obj->options, { foo => 'bar' }, '... got options now' ); is( exception { $obj->set_option( bar => 'baz' ); }, undef, '... set the option okay' ); is( $obj->num_options, 2, '... we have 2 option(s)' ); is_deeply( $obj->options, { foo => 'bar', bar => 'baz' }, '... got more options now' ); is( $obj->get_option('foo'), 'bar', '... got the right option' ); is_deeply( [ $obj->get_option(qw(foo bar)) ], [qw(bar baz)], "get multiple options at once" ); is( scalar( $obj->get_option(qw( foo bar)) ), "baz", '... got last option in scalar context' ); is( exception { $obj->set_option( oink => "blah", xxy => "flop" ); }, undef, '... set the option okay' ); is( $obj->num_options, 4, "4 options" ); is_deeply( [ $obj->get_option(qw(foo bar oink xxy)) ], [qw(bar baz blah flop)], "get multiple options at once" ); is( exception { is( scalar $obj->delete_option('bar'), 'baz', 'delete returns deleted value' ); }, undef, '... deleted the option okay' ); is( exception { is_deeply( [ $obj->delete_option( 'oink', 'xxy' ) ], [ 'blah', 'flop' ], 'delete returns all deleted values in list context' ); }, undef, '... deleted multiple option okay' ); is( $obj->num_options, 1, '... we have 1 option(s)' ); is_deeply( $obj->options, { foo => 'bar' }, '... got more options now' ); $obj->clear_options; is_deeply( $obj->options, {}, "... cleared options" ); is( exception { $obj->quantity(4); }, undef, '... options added okay with defaults' ); is( $obj->quantity, 4, 'reader part of curried accessor works' ); is( $obj->option_accessor('quantity'), 4, 'accessor as reader' ); is_deeply( $obj->options, { quantity => 4 }, '... returns what we expect' ); $obj->option_accessor( size => 42 ); like( exception { $obj->option_accessor; }, qr/Cannot call accessor without at least 1 argument/, 'error when calling accessor with no arguments' ); like( exception { $obj->option_accessor( undef, 'bar' ) }, qr/Hash keys passed to accessor must be defined/, 'exception when using undef as a key' ); is_deeply( $obj->options, { quantity => 4, size => 42 }, 'accessor as writer' ); is( exception { $class->new( options => { foo => 'BAR' } ); }, undef, '... good constructor params' ); isnt( exception { $obj->set_option( bar => {} ); }, undef, '... could not add a hash ref where an string is expected' ); isnt( exception { $class->new( options => { foo => [] } ); }, undef, '... bad constructor params' ); $obj->options( {} ); is_deeply( [ $obj->set_option( oink => "blah", xxy => "flop" ) ], [ 'blah', 'flop' ], 'set returns newly set values in order of keys provided' ); is_deeply( [ sort $obj->keys ], [ 'oink', 'xxy' ], 'keys returns expected keys' ); is_deeply( [ sort $obj->values ], [ 'blah', 'flop' ], 'values returns expected values' ); my @key_value = sort { $a->[0] cmp $b->[0] } $obj->key_value; is_deeply( \@key_value, [ sort { $a->[0] cmp $b->[0] }[ 'xxy', 'flop' ], [ 'oink', 'blah' ] ], '... got the right key value pairs' ) or do { require Data::Dumper; diag( Data::Dumper::Dumper( \@key_value ) ); }; my %options_elements = $obj->options_elements; is_deeply( \%options_elements, { 'oink' => 'blah', 'xxy' => 'flop' }, '... got the right hash elements' ); if ( $class->meta->get_attribute('options')->is_lazy ) { my $obj = $class->new; $obj->set_option( y => 2 ); is_deeply( $obj->options, { x => 1, y => 2 }, 'set_option with lazy default' ); $obj->_clear_options; ok( $obj->has_option('x'), 'key for x exists - lazy default' ); $obj->_clear_options; ok( $obj->is_defined('x'), 'key for x is defined - lazy default' ); $obj->_clear_options; is_deeply( [ $obj->key_value ], [ [ x => 1 ] ], 'kv returns lazy default' ); $obj->_clear_options; $obj->option_accessor( y => 2 ); is_deeply( [ sort $obj->keys ], [ 'x', 'y' ], 'accessor triggers lazy default generator' ); } } $class; } { my ( $class, $handles ) = build_class( isa => 'HashRef' ); my $obj = $class->new; with_immutable { is( exception { $obj->option_accessor( 'foo', undef ) }, undef, 'can use accessor to set value to undef' ); is( exception { $obj->quantity(undef) }, undef, 'can use accessor to set value to undef' ); } $class; } done_testing; find-dupe-test-numbers100755000767000024 76412200352344 20054 0ustar00etherstaff000000000000Moose-2.1005/author#!/usr/bin/perl use strict; use warnings; use File::Basename qw( basename ); for my $subdir ( glob 't/*' ) { my %files; for my $file ( map { basename($_) } glob "$subdir/*.t" ) { my ($number) = $file =~ /^(\d+)/; next unless defined $number; push @{ $files{$number} }, $file; } for my $number ( grep { @{ $files{$_} } > 1 } keys %files ) { print $subdir, "\n"; print ' - ', $_, "\n" for @{ $files{$number} }; print "\n"; } } Concepts.pod100644000767000024 3001512200352344 17702 0ustar00etherstaff000000000000Moose-2.1005/lib/Moose/Manualpackage Moose::Manual::Concepts; # ABSTRACT: Moose OO concepts __END__ =pod =head1 NAME Moose::Manual::Concepts - Moose OO concepts =head1 VERSION version 2.1005 =head1 MOOSE CONCEPTS (VS "OLD SCHOOL" Perl) In the past, you may not have thought too much about the difference between packages and classes, attributes and methods, constructors and methods, etc. With Moose, these are all conceptually separate, though under the hood they're implemented with plain old Perl. Our meta-object protocol (aka MOP) provides well-defined introspection features for each of those concepts, and Moose in turn provides distinct sugar for each of them. Moose also introduces additional concepts such as roles, method modifiers, and declarative delegation. Knowing what these concepts mean in Moose-speak, and how they used to be done in old school Perl 5 OO is a good way to start learning to use Moose. =head2 Class When you say "use Moose" in a package, you are making your package a class. At its simplest, a class will consist simply of attributes and/or methods. It can also include roles, method modifiers, and more. A class I zero or more B. A class I zero or more B. A class I zero or more superclasses (aka parent classes). A class inherits from its superclass(es). A class I zero or more B. These modifiers can apply to its own methods or methods that are inherited from its ancestors. A class I (and I) zero or more B. A class I a B and a B. These are provided for you "for free" by Moose. The B accepts named parameters corresponding to the class's attributes and uses them to initialize an B. A class I a B, which in turn has B, B, and B. This metaclass I the class. A class is usually analogous to a category of nouns, like "People" or "Users". package Person; use Moose; # now it's a Moose class! =head2 Attribute An attribute is a property of the class that defines it. It I has a name, and it I a number of other properties. These properties can include a read/write flag, a B, accessor method names, B, a default value, and more. Attributes I methods, but defining them causes various accessor methods to be created. At a minimum, a normal attribute will have a reader accessor method. Many attributes have other methods, such as a writer method, a clearer method, or a predicate method ("has it been set?"). An attribute may also define B, which will create additional methods based on the delegation mapping. By default, Moose stores attributes in the object instance, which is a hashref, I! It is best to think of Moose attributes as "properties" of the I B. These properties are accessed through well-defined accessor methods. An attribute is something that the class's members have. For example, People have first and last names. Users have passwords and last login datetimes. has 'first_name' => ( is => 'rw', isa => 'Str', ); =head2 Method A B is very straightforward. Any subroutine you define in your class is a method. B correspond to verbs, and are what your objects can do. For example, a User can login. sub login { ... } =head2 Role A role is something that a class I. We also say that classes I roles. For example, a Machine class might do the Breakable role, and so could a Bone class. A role is used to define some concept that cuts across multiple unrelated classes, like "breakability", or "has a color". A role I zero or more B. A role I zero or more B. A role I zero or more B. A role I zero or more B. A required method is not implemented by the role. Required methods are a way for the role to declare "to use this role you must implement this method". A role I zero or more B. An excluded role is a role that the role doing the excluding says it cannot be combined with. Roles are I into classes (or other roles). When a role is composed into a class, its attributes and methods are "flattened" into the class. Roles I show up in the inheritance hierarchy. When a role is composed, its attributes and methods appear as if they were defined I. Role are somewhat like mixins or interfaces in other OO languages. package Breakable; use Moose::Role; requires 'break'; has 'is_broken' => ( is => 'rw', isa => 'Bool', ); after 'break' => sub { my $self = shift; $self->is_broken(1); }; =head2 Method modifiers A B is a hook that is called when a named method is called. For example, you could say "before calling C, call this modifier first". Modifiers come in different flavors like "before", "after", "around", and "augment", and you can apply more than one modifier to a single method. Method modifiers are often used as an alternative to overriding a method in a parent class. They are also used in roles as a way of modifying methods in the consuming class. Under the hood, a method modifier is just a plain old Perl subroutine that gets called before or after (or around, etc.) some named method. before 'login' => sub { my $self = shift; my $pw = shift; warn "Called login() with $pw\n"; }; =head2 Type Moose also comes with a (miniature) type system. This allows you to define types for attributes. Moose has a set of built-in types based on the types Perl provides in its core, such as C, C, C, C, etc. In addition, every class name in your application can also be used as a type name. Finally, you can define your own types with their own constraints. For example, you could define a C type, a subtype of C which only allows positive numbers. =head2 Delegation Moose attributes provide declarative syntax for defining delegations. A delegation is a method which in turn calls some method on an attribute to do its real work. =head2 Constructor A constructor creates an B for the class. In old school Perl, this was usually done by defining a method called C which in turn called C on a reference. With Moose, this C method is created for you, and it simply does the right thing. You should never need to define your own constructor! Sometimes you want to do something whenever an object is created. In those cases, you can provide a C method in your class. Moose will call this for you after creating a new object. =head2 Destructor This is a special method called when an object instance goes out of scope. You can specialize what your class does in this method if you need to, but you usually don't. With old school Perl 5, this is the C method, but with Moose it is the C method. =head2 Object instance An object instance is a specific noun in the class's "category". For example, one specific Person or User. An instance is created by the class's B. An instance has values for its attributes. For example, a specific person has a first and last name. In old school Perl 5, this is often a blessed hash reference. With Moose, you should never need to know what your object instance actually is. (Okay, it's usually a blessed hashref with Moose, too.) =head2 Moose vs old school summary =over 4 =item * Class A package with no introspection other than mucking about in the symbol table. With Moose, you get well-defined declaration and introspection. =item * Attributes Hand-written accessor methods, symbol table hackery, or a helper module like C. With Moose, these are declaratively defined, and distinct from methods. =item * Method These are pretty much the same in Moose as in old school Perl. =item * Roles C or C, or maybe C. With Moose, they're part of the core feature set, and are introspectable like everything else. =item * Method Modifiers Could only be done through serious symbol table wizardry, and you probably never saw this before (at least in Perl 5). =item * Type Hand-written parameter checking in your C method and accessors. With Moose, you define types declaratively, and then use them by name with your attributes. =item * Delegation C or C, but probably even more hand-written code. With Moose, this is also declarative. =item * Constructor A C method which calls C on a reference. Comes for free when you define a class with Moose. =item * Destructor A C method. With Moose, this is called C. =item * Object Instance A blessed reference, usually a hash reference. With Moose, this is an opaque thing which has a bunch of attributes and methods, as defined by its class. =item * Immutabilization Moose comes with a feature called "immutabilization". When you make your class immutable, it means you're done adding methods, attributes, roles, etc. This lets Moose optimize your class with a bunch of extremely dirty in-place code generation tricks that speed up things like object construction and so on. =back =head1 META WHAT? A metaclass is a class that describes classes. With Moose, every class you define gets a C method. The C method returns a L object, which has an introspection API that can tell you about the class it represents. my $meta = User->meta(); for my $attribute ( $meta->get_all_attributes ) { print $attribute->name(), "\n"; if ( $attribute->has_type_constraint ) { print " type: ", $attribute->type_constraint->name, "\n"; } } for my $method ( $meta->get_all_methods ) { print $method->name, "\n"; } Almost every concept we defined earlier has a meta class, so we have L, L, L, L, L, L, and so on. =head1 BUT I NEED TO DO IT MY WAY! One of the great things about Moose is that if you dig down and find that it does something the "wrong way", you can change it by extending a metaclass. For example, you can have arrayref based objects, you can make your constructors strict (no unknown parameters allowed!), you can define a naming scheme for attribute accessors, you can make a class a Singleton, and much, much more. Many of these extensions require surprisingly small amounts of code, and once you've done it once, you'll never have to hand-code "your way of doing things" again. Instead you'll just load your favorite extensions. package MyWay::User; use Moose; use MooseX::StrictConstructor; use MooseX::MyWay; has ...; =head1 WHAT NEXT? So you're sold on Moose. Time to learn how to really use it. If you want to see how Moose would translate directly into old school Perl 5 OO code, check out L. This might be helpful for quickly wrapping your brain around some aspects of "the Moose way". Or you can skip that and jump straight to L and the rest of the L. After that we recommend that you start with the L. If you work your way through all the recipes under the basics section, you should have a pretty good sense of how Moose works, and all of its basic OO features. After that, check out the Role recipes. If you're really curious, go on and read the Meta and Extending recipes, but those are mostly there for people who want to be Moose wizards and extend Moose itself. =head1 AUTHOR Moose is maintained by the Moose Cabal, along with the help of many contributors. See L and L for details. =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2013 by Infinity Interactive, Inc.. This is free software; you can redistribute it and/or modify it under the same terms as the Perl 5 programming language system itself. =cut Method000755000767000024 012200352344 16132 5ustar00etherstaff000000000000Moose-2.1005/lib/Moose/MetaMeta.pm100644000767000024 306612200352344 17523 0ustar00etherstaff000000000000Moose-2.1005/lib/Moose/Meta/Method package Moose::Meta::Method::Meta; BEGIN { $Moose::Meta::Method::Meta::AUTHORITY = 'cpan:STEVAN'; } { $Moose::Meta::Method::Meta::VERSION = '2.1005'; } use strict; use warnings; use base 'Moose::Meta::Method', 'Class::MOP::Method::Meta'; sub _is_caller_mop_internal { my $self = shift; my ($caller) = @_; return 1 if $caller =~ /^Moose(?:::|$)/; return $self->SUPER::_is_caller_mop_internal($caller); } # XXX: ugh multiple inheritance sub wrap { my $class = shift; return $class->Class::MOP::Method::Meta::wrap(@_); } sub _make_compatible_with { my $self = shift; return $self->Class::MOP::Method::Meta::_make_compatible_with(@_); } 1; # ABSTRACT: A Moose Method metaclass for C methods __END__ =pod =head1 NAME Moose::Meta::Method::Meta - A Moose Method metaclass for C methods =head1 VERSION version 2.1005 =head1 DESCRIPTION This class is a subclass of L that provides additional Moose-specific functionality, all of which is private. To understand this class, you should read the the L documentation. =head1 BUGS See L for details on reporting bugs. =head1 AUTHOR Moose is maintained by the Moose Cabal, along with the help of many contributors. See L and L for details. =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2013 by Infinity Interactive, Inc.. This is free software; you can redistribute it and/or modify it under the same terms as the Perl 5 programming language system itself. =cut Role000755000767000024 012200352344 15613 5ustar00etherstaff000000000000Moose-2.1005/lib/Moose/MetaMethod.pm100644000767000024 251712200352344 17536 0ustar00etherstaff000000000000Moose-2.1005/lib/Moose/Meta/Role package Moose::Meta::Role::Method; BEGIN { $Moose::Meta::Role::Method::AUTHORITY = 'cpan:STEVAN'; } { $Moose::Meta::Role::Method::VERSION = '2.1005'; } use strict; use warnings; use base 'Moose::Meta::Method'; sub _make_compatible_with { my $self = shift; my ($other) = @_; # XXX: this is pretty gross. the issue here is blah blah blah # see the comments in CMOP::Method::Meta and CMOP::Method::Wrapped return $self unless $other->_is_compatible_with($self->_real_ref_name); return $self->SUPER::_make_compatible_with(@_); } 1; # ABSTRACT: A Moose Method metaclass for Roles __END__ =pod =head1 NAME Moose::Meta::Role::Method - A Moose Method metaclass for Roles =head1 VERSION version 2.1005 =head1 DESCRIPTION This is primarily used to mark methods coming from a role as being different. Right now it is nothing but a subclass of L. =head1 BUGS See L for details on reporting bugs. =head1 AUTHOR Moose is maintained by the Moose Cabal, along with the help of many contributors. See L and L for details. =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2013 by Infinity Interactive, Inc.. This is free software; you can redistribute it and/or modify it under the same terms as the Perl 5 programming language system itself. =cut attribute_does.t100644000767000024 432012200352344 20166 0ustar00etherstaff000000000000Moose-2.1005/t/attributes#!/usr/bin/perl use strict; use warnings; use Test::More; use Test::Fatal; { package Foo::Role; use Moose::Role; use Moose::Util::TypeConstraints; # if does() exists on its own, then # we create a type constraint for # it, just as we do for isa() has 'bar' => (is => 'rw', does => 'Bar::Role'); has 'baz' => ( is => 'rw', does => role_type('Bar::Role') ); package Foo::Class; use Moose; with 'Foo::Role'; package Bar::Role; use Moose::Role; # if isa and does appear together, then see if Class->does(Role) # if it does work... then the does() check is actually not needed # since the isa() check will imply the does() check has 'foo' => (is => 'rw', isa => 'Foo::Class', does => 'Foo::Role'); package Bar::Class; use Moose; with 'Bar::Role'; } my $foo = Foo::Class->new; isa_ok($foo, 'Foo::Class'); my $bar = Bar::Class->new; isa_ok($bar, 'Bar::Class'); is( exception { $foo->bar($bar); }, undef, '... bar passed the type constraint okay' ); isnt( exception { $foo->bar($foo); }, undef, '... foo did not pass the type constraint okay' ); is( exception { $foo->baz($bar); }, undef, '... baz passed the type constraint okay' ); isnt( exception { $foo->baz($foo); }, undef, '... foo did not pass the type constraint okay' ); is( exception { $bar->foo($foo); }, undef, '... foo passed the type constraint okay' ); # some error conditions { package Baz::Class; use Moose; # if isa and does appear together, then see if Class->does(Role) # if it does not,.. we have a conflict... so we die loudly ::isnt( ::exception { has 'foo' => (isa => 'Foo::Class', does => 'Bar::Class'); }, undef, '... cannot have a does() which is not done by the isa()' ); } { package Bling; use strict; use warnings; sub bling { 'Bling::bling' } package Bling::Bling; use Moose; # if isa and does appear together, then see if Class->does(Role) # if it does not,.. we have a conflict... so we die loudly ::isnt( ::exception { has 'foo' => (isa => 'Bling', does => 'Bar::Class'); }, undef, '... cannot have a isa() which is cannot does()' ); } done_testing; no_slot_access.t100644000767000024 344012200352344 20151 0ustar00etherstaff000000000000Moose-2.1005/t/attributes#!/usr/bin/perl use strict; use warnings; { package SomeAwesomeDB; sub new_row { } sub read { } sub write { } } { package MooseX::SomeAwesomeDBFields; # implementation of methods not called in the example deliberately # omitted use Moose::Role; sub inline_create_instance { my ( $self, $classvar ) = @_; "bless SomeAwesomeDB::new_row(), $classvar"; } sub inline_get_slot_value { my ( $self, $invar, $slot ) = @_; "SomeAwesomeDB::read($invar, \"$slot\")"; } sub inline_set_slot_value { my ( $self, $invar, $slot, $valexp ) = @_; "SomeAwesomeDB::write($invar, \"$slot\", $valexp)"; } sub inline_is_slot_initialized { my ( $self, $invar, $slot ) = @_; "1"; } sub inline_initialize_slot { my ( $self, $invar, $slot ) = @_; ""; } sub inline_slot_access { die "inline_slot_access should not have been used"; } } { package Toy; use Moose; use Moose::Util::MetaRole; use Test::More; use Test::Fatal; Moose::Util::MetaRole::apply_metaroles( for => __PACKAGE__, class_metaroles => { instance => ['MooseX::SomeAwesomeDBFields'] }, ); is( exception { has lazy_attr => ( is => 'ro', isa => 'Bool', lazy => 1, default => sub {0}, ); }, undef, "Adding lazy accessor does not use inline_slot_access" ); is( exception { has rw_attr => ( is => 'rw', ); }, undef, "Adding read-write accessor does not use inline_slot_access" ); is( exception { __PACKAGE__->meta->make_immutable; }, undef, "Inling constructor does not use inline_slot_access" ); done_testing; } global_destruction.t100644000767000024 143312200352344 20114 0ustar00etherstaff000000000000Moose-2.1005/t/basics#!/usr/bin/perl use strict; use warnings; use Test::More; { package Foo; use Moose; sub DEMOLISH { my $self = shift; my ($igd) = @_; ::ok( !$igd, 'in_global_destruction state is passed to DEMOLISH properly (false)' ); } } { my $foo = Foo->new; } { package Bar; use Moose; sub DEMOLISH { my $self = shift; my ($igd) = @_; ::ok( !$igd, 'in_global_destruction state is passed to DEMOLISH properly (false)' ); } __PACKAGE__->meta->make_immutable; } { my $bar = Bar->new; } ok( $_, 'in_global_destruction state is passed to DEMOLISH properly (true)' ) for split //, `$^X t/basics/global-destruction-helper.pl`; done_testing; super_and_override.t100644000767000024 326112200352344 20111 0ustar00etherstaff000000000000Moose-2.1005/t/basics#!/usr/bin/perl use strict; use warnings; use Test::More; use Test::Fatal; { package Foo; use Moose; sub foo { 'Foo::foo' } sub bar { 'Foo::bar' } sub baz { 'Foo::baz' } package Bar; use Moose; extends 'Foo'; override bar => sub { 'Bar::bar -> ' . super() }; package Baz; use Moose; extends 'Bar'; override bar => sub { 'Baz::bar -> ' . super() }; override baz => sub { 'Baz::baz -> ' . super() }; no Moose; # ensure super() still works after unimport } my $baz = Baz->new(); isa_ok($baz, 'Baz'); isa_ok($baz, 'Bar'); isa_ok($baz, 'Foo'); is($baz->foo(), 'Foo::foo', '... got the right value from &foo'); is($baz->bar(), 'Baz::bar -> Bar::bar -> Foo::bar', '... got the right value from &bar'); is($baz->baz(), 'Baz::baz -> Foo::baz', '... got the right value from &baz'); my $bar = Bar->new(); isa_ok($bar, 'Bar'); isa_ok($bar, 'Foo'); is($bar->foo(), 'Foo::foo', '... got the right value from &foo'); is($bar->bar(), 'Bar::bar -> Foo::bar', '... got the right value from &bar'); is($bar->baz(), 'Foo::baz', '... got the right value from &baz'); my $foo = Foo->new(); isa_ok($foo, 'Foo'); is($foo->foo(), 'Foo::foo', '... got the right value from &foo'); is($foo->bar(), 'Foo::bar', '... got the right value from &bar'); is($foo->baz(), 'Foo::baz', '... got the right value from &baz'); # some error cases { package Bling; use Moose; sub bling { 'Bling::bling' } package Bling::Bling; use Moose; extends 'Bling'; sub bling { 'Bling::bling' } ::isnt( ::exception { override 'bling' => sub {}; }, undef, '... cannot override a method which has a local equivalent' ); } done_testing; moose_octal_defaults.t100644000767000024 405112200352344 20117 0ustar00etherstaff000000000000Moose-2.1005/t/bugs#!/usr/bin/env perl use Test::More; { my $package = qq{ package Test::Moose::Go::Boom; use Moose; use lib qw(lib); has id => ( isa => 'Str', is => 'ro', default => '019600', # this caused the original failure ); no Moose; __PACKAGE__->meta->make_immutable; }; eval $package; $@ ? ::fail($@) : ::pass('quoted 019600 default works'); my $obj = Test::Moose::Go::Boom->new; ::is( $obj->id, '019600', 'value is still the same' ); } { my $package = qq{ package Test::Moose::Go::Boom2; use Moose; use lib qw(lib); has id => ( isa => 'Str', is => 'ro', default => 017600, ); no Moose; __PACKAGE__->meta->make_immutable; }; eval $package; $@ ? ::fail($@) : ::pass('017600 octal default works'); my $obj = Test::Moose::Go::Boom2->new; ::is( $obj->id, 8064, 'value is still the same' ); } { my $package = qq{ package Test::Moose::Go::Boom3; use Moose; use lib qw(lib); has id => ( isa => 'Str', is => 'ro', default => 0xFF, ); no Moose; __PACKAGE__->meta->make_immutable; }; eval $package; $@ ? ::fail($@) : ::pass('017600 octal default works'); my $obj = Test::Moose::Go::Boom3->new; ::is( $obj->id, 255, 'value is still the same' ); } { my $package = qq{ package Test::Moose::Go::Boom4; use Moose; use lib qw(lib); has id => ( isa => 'Str', is => 'ro', default => '0xFF', ); no Moose; __PACKAGE__->meta->make_immutable; }; eval $package; $@ ? ::fail($@) : ::pass('017600 octal default works'); my $obj = Test::Moose::Go::Boom4->new; ::is( $obj->id, '0xFF', 'value is still the same' ); } { my $package = qq{ package Test::Moose::Go::Boom5; use Moose; use lib qw(lib); has id => ( isa => 'Str', is => 'ro', default => '0 but true', ); no Moose; __PACKAGE__->meta->make_immutable; }; eval $package; $@ ? ::fail($@) : ::pass('017600 octal default works'); my $obj = Test::Moose::Go::Boom5->new; ::is( $obj->id, '0 but true', 'value is still the same' ); } done_testing; subtype_conflict_bug.t100644000767000024 21512200352344 20113 0ustar00etherstaff000000000000Moose-2.1005/t/bugs#!/usr/bin/perl use strict; use warnings; use lib 't/lib', 'lib'; use Test::More; use_ok('MyMooseA'); use_ok('MyMooseB'); done_testing; traits_with_exporter.t100644000767000024 270712200352344 20223 0ustar00etherstaff000000000000Moose-2.1005/t/bugs#!/usr/bin/perl use lib "t/lib"; use strict; use warnings; use Test::More; BEGIN { package MyExporterRole; use Moose (); use Moose::Exporter; Moose::Exporter->setup_import_methods( also => 'Moose', ); sub init_meta { my ($class,%args) = @_; my $meta = Moose->init_meta( %args ); Moose::Util::MetaRole::apply_metaroles( for => $meta, class_metaroles => { class => ['MyMetaRole'], }, ); return $meta; } $INC{'MyExporterRole.pm'} = __FILE__; } { package MyMetaRole; use Moose::Role; sub some_meta_class_method { return "HEY" } } { package MyTrait; use Moose::Role; sub some_meta_class_method_defined_by_trait { return "HO" } { package Moose::Meta::Class::Custom::Trait::MyClassTrait; use strict; use warnings; sub register_implementation { return 'MyTrait' } } } { package MyClass; use MyExporterRole -traits => 'MyClassTrait'; } my $my_class = MyClass->new; isa_ok($my_class,'MyClass'); my $meta = $my_class->meta(); # Check if MyMetaRole has been applied ok($meta->can('some_meta_class_method'),'Meta class has some_meta_class_method'); # Check if MyTrait has been applied ok($meta->can('some_meta_class_method_defined_by_trait'),'Meta class has some_meta_class_method_defined_by_trait'); done_testing; inline_and_dollar_at.t100644000767000024 42612200352344 20025 0ustar00etherstaff000000000000Moose-2.1005/t/cmopuse strict; use warnings; use Test::More; use Class::MOP; { package Foo; my $meta = Class::MOP::Class->initialize(__PACKAGE__); $@ = 'dollar at'; $meta->make_immutable; ::is( $@, 'dollar at', '$@ is untouched after immutablization' ); } done_testing; modify_parent_method.t100644000767000024 316312200352344 20125 0ustar00etherstaff000000000000Moose-2.1005/t/cmopuse strict; use warnings; use Test::More; use Test::Fatal; use Class::MOP; my @calls; { package Parent; use strict; use warnings; use metaclass; use Carp 'confess'; sub method { push @calls, 'Parent::method' } package Child; use strict; use warnings; use metaclass; use base 'Parent'; Child->meta->add_around_method_modifier( 'method' => sub { my $orig = shift; push @calls, 'before Child::method'; $orig->(@_); push @calls, 'after Child::method'; } ); } Parent->method; is_deeply( [ splice @calls ], [ 'Parent::method', ] ); Child->method; is_deeply( [ splice @calls ], [ 'before Child::method', 'Parent::method', 'after Child::method', ] ); { package Parent; Parent->meta->add_around_method_modifier( 'method' => sub { my $orig = shift; push @calls, 'before Parent::method'; $orig->(@_); push @calls, 'after Parent::method'; } ); } Parent->method; is_deeply( [ splice @calls ], [ 'before Parent::method', 'Parent::method', 'after Parent::method', ] ); Child->method; TODO: { local $TODO = "pending fix"; is_deeply( [ splice @calls ], [ 'before Child::method', 'before Parent::method', 'Parent::method', 'after Parent::method', 'after Child::method', ], "cache is correctly invalidated when the parent method is wrapped" ); } done_testing; immutable_moose.t100644000767000024 431212200352344 20124 0ustar00etherstaff000000000000Moose-2.1005/t/immutable#!/usr/bin/perl use strict; use warnings; use Test::More; use Test::Fatal; use Moose::Meta::Role; { package FooRole; our $VERSION = '0.01'; sub foo {'FooRole::foo'} } { package Foo; use Moose; #two checks because the inlined methods are different when #there is a TC present. has 'foos' => ( is => 'ro', lazy_build => 1 ); has 'bars' => ( isa => 'Str', is => 'ro', lazy_build => 1 ); has 'bazes' => ( isa => 'Str', is => 'ro', builder => '_build_bazes' ); sub _build_foos {"many foos"} sub _build_bars {"many bars"} sub _build_bazes {"many bazes"} } { my $foo_role = Moose::Meta::Role->initialize('FooRole'); my $meta = Foo->meta; is( exception { Foo->new }, undef, "lazy_build works" ); is( Foo->new->foos, 'many foos', "correct value for 'foos' before inlining constructor" ); is( Foo->new->bars, 'many bars', "correct value for 'bars' before inlining constructor" ); is( Foo->new->bazes, 'many bazes', "correct value for 'bazes' before inlining constructor" ); is( exception { $meta->make_immutable }, undef, "Foo is imutable" ); is( exception { $meta->identifier }, undef, "->identifier on metaclass lives" ); isnt( exception { $meta->add_role($foo_role) }, undef, "Add Role is locked" ); is( exception { Foo->new }, undef, "Inlined constructor works with lazy_build" ); is( Foo->new->foos, 'many foos', "correct value for 'foos' after inlining constructor" ); is( Foo->new->bars, 'many bars', "correct value for 'bars' after inlining constructor" ); is( Foo->new->bazes, 'many bazes', "correct value for 'bazes' after inlining constructor" ); is( exception { $meta->make_mutable }, undef, "Foo is mutable" ); is( exception { $meta->add_role($foo_role) }, undef, "Add Role is unlocked" ); } { package Bar; use Moose; sub BUILD { 'bar' } } { package Baz; use Moose; extends 'Bar'; sub BUILD { 'baz' } } is( exception { Bar->meta->make_immutable }, undef, 'Immutable meta with single BUILD' ); is( exception { Baz->meta->make_immutable }, undef, 'Immutable meta with multiple BUILDs' ); =pod Nothing here yet, but soon :) =cut done_testing; new_metaclass.t100644000767000024 105712200352344 20120 0ustar00etherstaff000000000000Moose-2.1005/t/metaclasses#!/usr/bin/env perl use strict; use warnings; use Test::More; do { package My::Meta::Class; use Moose; BEGIN { extends 'Moose::Meta::Class' }; package Moose::Meta::Class::Custom::MyMetaClass; sub register_implementation { 'My::Meta::Class' } }; do { package My::Class; use Moose -metaclass => 'My::Meta::Class'; }; do { package My::Class::Aliased; use Moose -metaclass => 'MyMetaClass'; }; is(My::Class->meta->meta->name, 'My::Meta::Class'); is(My::Class::Aliased->meta->meta->name, 'My::Meta::Class'); done_testing; hash_coerce.t100644000767000024 525712200352344 20114 0ustar00etherstaff000000000000Moose-2.1005/t/native_traitsuse strict; use warnings; use Test::More; { package Foo; use Moose; use Moose::Util::TypeConstraints; subtype 'UCHash', as 'HashRef[Str]', where { !grep {/[a-z]/} values %{$_}; }; coerce 'UCHash', from 'HashRef[Str]', via { $_ = uc $_ for values %{$_}; $_; }; has hash => ( traits => ['Hash'], is => 'rw', isa => 'UCHash', coerce => 1, handles => { set_key => 'set', }, ); our @TriggerArgs; has lazy => ( traits => ['Hash'], is => 'rw', isa => 'UCHash', coerce => 1, lazy => 1, default => sub { { x => 'a' } }, handles => { set_lazy => 'set', }, trigger => sub { @TriggerArgs = @_ }, clearer => 'clear_lazy', ); } my $foo = Foo->new; { $foo->hash( { x => 'A', y => 'B' } ); $foo->set_key( z => 'c' ); is_deeply( $foo->hash, { x => 'A', y => 'B', z => 'C' }, 'set coerces the hash' ); } { $foo->set_lazy( y => 'b' ); is_deeply( $foo->lazy, { x => 'A', y => 'B' }, 'set coerces the hash - lazy' ); is_deeply( \@Foo::TriggerArgs, [ $foo, { x => 'A', y => 'B' }, { x => 'A' } ], 'trigger receives expected arguments' ); } { package Thing; use Moose; has thing => ( is => 'ro', isa => 'Str', ); } { package Bar; use Moose; use Moose::Util::TypeConstraints; class_type 'Thing'; coerce 'Thing' => from 'Str' => via { Thing->new( thing => $_ ) }; subtype 'HashRefOfThings' => as 'HashRef[Thing]'; coerce 'HashRefOfThings' => from 'HashRef[Str]' => via { my %new; for my $k ( keys %{$_} ) { $new{$k} = Thing->new( thing => $_->{$k} ); } return \%new; }; coerce 'HashRefOfThings' => from 'Str' => via { [ Thing->new( thing => $_ ) ] }; has hash => ( traits => ['Hash'], is => 'rw', isa => 'HashRefOfThings', coerce => 1, handles => { set_hash => 'set', get_hash => 'get', }, ); } { my $bar = Bar->new( hash => { foo => 1, bar => 2 } ); is( $bar->get_hash('foo')->thing, 1, 'constructor coerces hash reference' ); $bar->set_hash( baz => 3, quux => 4 ); is( $bar->get_hash('baz')->thing, 3, 'set coerces new hash values' ); is( $bar->get_hash('quux')->thing, 4, 'set coerces new hash values' ); } done_testing; trait_array.t100644000767000024 6206412200352344 20211 0ustar00etherstaff000000000000Moose-2.1005/t/native_traits#!/usr/bin/perl use strict; use warnings; use lib 't/lib'; use Moose (); use Moose::Util::TypeConstraints; use NoInlineAttribute; use Test::More; use Test::Fatal; use Test::Moose; { my %handles = ( count => 'count', elements => 'elements', is_empty => 'is_empty', push => 'push', push_curried => [ push => 42, 84 ], unshift => 'unshift', unshift_curried => [ unshift => 42, 84 ], pop => 'pop', shift => 'shift', get => 'get', get_curried => [ get => 1 ], set => 'set', set_curried_1 => [ set => 1 ], set_curried_2 => [ set => ( 1, 98 ) ], accessor => 'accessor', accessor_curried_1 => [ accessor => 1 ], accessor_curried_2 => [ accessor => ( 1, 90 ) ], clear => 'clear', delete => 'delete', delete_curried => [ delete => 1 ], insert => 'insert', insert_curried => [ insert => ( 1, 101 ) ], splice => 'splice', splice_curried_1 => [ splice => 1 ], splice_curried_2 => [ splice => 1, 2 ], splice_curried_all => [ splice => 1, 2, ( 3, 4, 5 ) ], sort => 'sort', sort_curried => [ sort => ( sub { $_[1] <=> $_[0] } ) ], sort_in_place => 'sort_in_place', sort_in_place_curried => [ sort_in_place => ( sub { $_[1] <=> $_[0] } ) ], map => 'map', map_curried => [ map => ( sub { $_ + 1 } ) ], grep => 'grep', grep_curried => [ grep => ( sub { $_ < 5 } ) ], first => 'first', first_curried => [ first => ( sub { $_ % 2 } ) ], first_index => 'first_index', first_index_curried => [ first_index => ( sub { $_ % 2 } ) ], join => 'join', join_curried => [ join => '-' ], shuffle => 'shuffle', uniq => 'uniq', reduce => 'reduce', reduce_curried => [ reduce => ( sub { $_[0] * $_[1] } ) ], natatime => 'natatime', natatime_curried => [ natatime => 2 ], ); my $name = 'Foo1'; sub build_class { my %attr = @_; my $class = Moose::Meta::Class->create( $name++, superclasses => ['Moose::Object'], ); my @traits = 'Array'; push @traits, 'NoInlineAttribute' if delete $attr{no_inline}; $class->add_attribute( _values => ( traits => \@traits, is => 'rw', isa => 'ArrayRef[Int]', default => sub { [] }, handles => \%handles, clearer => '_clear_values', %attr, ), ); return ( $class->name, \%handles ); } } { package Overloader; use overload '&{}' => sub { ${ $_[0] } }, bool => sub {1}; sub new { bless \$_[1], $_[0]; } } { package OverloadStr; use overload q{""} => sub { ${ $_[0] } }, fallback => 1; sub new { my $class = shift; my $str = shift; return bless \$str, $class; } } { run_tests(build_class); run_tests( build_class( lazy => 1, default => sub { [ 42, 84 ] } ) ); run_tests( build_class( trigger => sub { } ) ); run_tests( build_class( no_inline => 1 ) ); # Will force the inlining code to check the entire arrayref when it is modified. subtype 'MyArrayRef', as 'ArrayRef', where { 1 }; run_tests( build_class( isa => 'MyArrayRef' ) ); coerce 'MyArrayRef', from 'ArrayRef', via { $_ }; run_tests( build_class( isa => 'MyArrayRef', coerce => 1 ) ); } sub run_tests { my ( $class, $handles ) = @_; can_ok( $class, $_ ) for sort keys %{$handles}; with_immutable { my $obj = $class->new( _values => [ 10, 12, 42 ] ); is_deeply( $obj->_values, [ 10, 12, 42 ], 'values can be set in constructor' ); ok( !$obj->is_empty, 'values is not empty' ); is( $obj->count, 3, 'count returns 3' ); like( exception { $obj->count(22) }, qr/Cannot call count with any arguments/, 'throws an error when passing an argument passed to count' ); is( exception { $obj->push( 1, 2, 3 ) }, undef, 'pushed three new values and lived' ); is( exception { $obj->push() }, undef, 'call to push without arguments lives' ); is( exception { is( $obj->unshift( 101, 22 ), 8, 'unshift returns size of the new array' ); }, undef, 'unshifted two values and lived' ); is_deeply( $obj->_values, [ 101, 22, 10, 12, 42, 1, 2, 3 ], 'unshift changed the value of the array in the object' ); is( exception { $obj->unshift() }, undef, 'call to unshift without arguments lives' ); is( $obj->pop, 3, 'pop returns the last value in the array' ); is_deeply( $obj->_values, [ 101, 22, 10, 12, 42, 1, 2 ], 'pop changed the value of the array in the object' ); like( exception { $obj->pop(42) }, qr/Cannot call pop with any arguments/, 'call to pop with arguments dies' ); is( $obj->shift, 101, 'shift returns the first value' ); like( exception { $obj->shift(42) }, qr/Cannot call shift with any arguments/, 'call to shift with arguments dies' ); is_deeply( $obj->_values, [ 22, 10, 12, 42, 1, 2 ], 'shift changed the value of the array in the object' ); is_deeply( [ $obj->elements ], [ 22, 10, 12, 42, 1, 2 ], 'call to elements returns values as a list' ); like( exception { $obj->elements(22) }, qr/Cannot call elements with any arguments/, 'throws an error when passing an argument passed to elements' ); $obj->_values( [ 1, 2, 3 ] ); is( $obj->get(0), 1, 'get values at index 0' ); is( $obj->get(1), 2, 'get values at index 1' ); is( $obj->get(2), 3, 'get values at index 2' ); is( $obj->get_curried, 2, 'get_curried returns value at index 1' ); like( exception { $obj->get() }, qr/Cannot call get without at least 1 argument/, 'throws an error when get is called without any arguments' ); like( exception { $obj->get( {} ) }, qr/The index passed to get must be an integer/, 'throws an error when get is called with an invalid argument' ); like( exception { $obj->get(2.2) }, qr/The index passed to get must be an integer/, 'throws an error when get is called with an invalid argument' ); like( exception { $obj->get('foo') }, qr/The index passed to get must be an integer/, 'throws an error when get is called with an invalid argument' ); like( exception { $obj->get_curried(2) }, qr/Cannot call get with more than 1 argument/, 'throws an error when get_curried is called with an argument' ); is( exception { is( $obj->set( 1, 100 ), 100, 'set returns new value' ); }, undef, 'set value at index 1 lives' ); is( $obj->get(1), 100, 'get value at index 1 returns new value' ); like( exception { $obj->set( 1, 99, 42 ) }, qr/Cannot call set with more than 2 arguments/, 'throws an error when set is called with three arguments' ); is( exception { $obj->set_curried_1(99) }, undef, 'set_curried_1 lives' ); is( $obj->get(1), 99, 'get value at index 1 returns new value' ); like( exception { $obj->set_curried_1( 99, 42 ) }, qr/Cannot call set with more than 2 arguments/, 'throws an error when set_curried_1 is called with two arguments' ); is( exception { $obj->set_curried_2 }, undef, 'set_curried_2 lives' ); is( $obj->get(1), 98, 'get value at index 1 returns new value' ); like( exception { $obj->set_curried_2(42) }, qr/Cannot call set with more than 2 arguments/, 'throws an error when set_curried_2 is called with one argument' ); is( $obj->accessor(1), 98, 'accessor with one argument returns value at index 1' ); is( exception { is( $obj->accessor( 1 => 97 ), 97, 'accessor returns new value' ); }, undef, 'accessor as writer lives' ); like( exception { $obj->accessor; }, qr/Cannot call accessor without at least 1 argument/, 'throws an error when accessor is called without arguments' ); is( $obj->get(1), 97, 'accessor set value at index 1' ); like( exception { $obj->accessor( 1, 96, 42 ) }, qr/Cannot call accessor with more than 2 arguments/, 'throws an error when accessor is called with three arguments' ); is( $obj->accessor_curried_1, 97, 'accessor_curried_1 returns expected value when called with no arguments' ); is( exception { $obj->accessor_curried_1(95) }, undef, 'accessor_curried_1 as writer lives' ); is( $obj->get(1), 95, 'accessor_curried_1 set value at index 1' ); like( exception { $obj->accessor_curried_1( 96, 42 ) }, qr/Cannot call accessor with more than 2 arguments/, 'throws an error when accessor_curried_1 is called with two arguments' ); is( exception { $obj->accessor_curried_2 }, undef, 'accessor_curried_2 as writer lives' ); is( $obj->get(1), 90, 'accessor_curried_2 set value at index 1' ); like( exception { $obj->accessor_curried_2(42) }, qr/Cannot call accessor with more than 2 arguments/, 'throws an error when accessor_curried_2 is called with one argument' ); is( exception { $obj->clear }, undef, 'clear lives' ); ok( $obj->is_empty, 'values is empty after call to clear' ); is( exception { is( $obj->shift, undef, 'shift returns undef on an empty array' ); }, undef, 'shifted from an empty array and lived' ); $obj->set( 0 => 42 ); like( exception { $obj->clear(50) }, qr/Cannot call clear with any arguments/, 'throws an error when clear is called with an argument' ); ok( !$obj->is_empty, 'values is not empty after failed call to clear' ); like( exception { $obj->is_empty(50) }, qr/Cannot call is_empty with any arguments/, 'throws an error when is_empty is called with an argument' ); $obj->clear; is( $obj->push( 1, 5, 10, 42 ), 4, 'pushed 4 elements, got number of elements in the array back' ); is( exception { is( $obj->delete(2), 10, 'delete returns deleted value' ); }, undef, 'delete lives' ); is_deeply( $obj->_values, [ 1, 5, 42 ], 'delete removed the specified element' ); like( exception { $obj->delete( 2, 3 ) }, qr/Cannot call delete with more than 1 argument/, 'throws an error when delete is called with two arguments' ); is( exception { $obj->delete_curried }, undef, 'delete_curried lives' ); is_deeply( $obj->_values, [ 1, 42 ], 'delete removed the specified element' ); like( exception { $obj->delete_curried(2) }, qr/Cannot call delete with more than 1 argument/, 'throws an error when delete_curried is called with one argument' ); is( exception { $obj->insert( 1, 21 ) }, undef, 'insert lives' ); is_deeply( $obj->_values, [ 1, 21, 42 ], 'insert added the specified element' ); like( exception { $obj->insert( 1, 22, 44 ) }, qr/Cannot call insert with more than 2 arguments/, 'throws an error when insert is called with three arguments' ); is( exception { is_deeply( [ $obj->splice( 1, 0, 2, 3 ) ], [], 'return value of splice is empty list when not removing elements' ); }, undef, 'splice lives' ); is_deeply( $obj->_values, [ 1, 2, 3, 21, 42 ], 'splice added the specified elements' ); is( exception { is_deeply( [ $obj->splice( 1, 2, 99 ) ], [ 2, 3 ], 'splice returns list of removed values' ); }, undef, 'splice lives' ); is_deeply( $obj->_values, [ 1, 99, 21, 42 ], 'splice added the specified elements' ); like( exception { $obj->splice() }, qr/Cannot call splice without at least 1 argument/, 'throws an error when splice is called with no arguments' ); like( exception { $obj->splice( 1, 'foo', ) }, qr/The length argument passed to splice must be an integer/, 'throws an error when splice is called with an invalid length' ); is( exception { $obj->splice_curried_1( 2, 101 ) }, undef, 'splice_curried_1 lives' ); is_deeply( $obj->_values, [ 1, 101, 42 ], 'splice added the specified elements' ); is( exception { $obj->splice_curried_2(102) }, undef, 'splice_curried_2 lives' ); is_deeply( $obj->_values, [ 1, 102 ], 'splice added the specified elements' ); is( exception { $obj->splice_curried_all }, undef, 'splice_curried_all lives' ); is_deeply( $obj->_values, [ 1, 3, 4, 5 ], 'splice added the specified elements' ); is_deeply( scalar $obj->splice( 1, 2 ), 4, 'splice in scalar context returns last element removed' ); is_deeply( scalar $obj->splice( 1, 0, 42 ), undef, 'splice in scalar context returns undef when no elements are removed' ); $obj->_values( [ 3, 9, 5, 22, 11 ] ); is_deeply( [ $obj->sort ], [ 11, 22, 3, 5, 9 ], 'sort returns sorted values' ); is_deeply( [ $obj->sort( sub { $_[0] <=> $_[1] } ) ], [ 3, 5, 9, 11, 22 ], 'sort returns values sorted by provided function' ); like( exception { $obj->sort(1) }, qr/The argument passed to sort must be a code reference/, 'throws an error when passing a non coderef to sort' ); like( exception { $obj->sort( sub { }, 27 ); }, qr/Cannot call sort with more than 1 argument/, 'throws an error when passing two arguments to sort' ); $obj->_values( [ 3, 9, 5, 22, 11 ] ); $obj->sort_in_place; is_deeply( $obj->_values, [ 11, 22, 3, 5, 9 ], 'sort_in_place sorts values' ); $obj->sort_in_place( sub { $_[0] <=> $_[1] } ); is_deeply( $obj->_values, [ 3, 5, 9, 11, 22 ], 'sort_in_place with function sorts values' ); like( exception { $obj->sort_in_place( 27 ); }, qr/The argument passed to sort_in_place must be a code reference/, 'throws an error when passing a non coderef to sort_in_place' ); like( exception { $obj->sort_in_place( sub { }, 27 ); }, qr/Cannot call sort_in_place with more than 1 argument/, 'throws an error when passing two arguments to sort_in_place' ); $obj->_values( [ 3, 9, 5, 22, 11 ] ); $obj->sort_in_place_curried; is_deeply( $obj->_values, [ 22, 11, 9, 5, 3 ], 'sort_in_place_curried sorts values' ); like( exception { $obj->sort_in_place_curried(27) }, qr/Cannot call sort_in_place with more than 1 argument/, 'throws an error when passing one argument passed to sort_in_place_curried' ); $obj->_values( [ 1 .. 5 ] ); is_deeply( [ $obj->map( sub { $_ + 1 } ) ], [ 2 .. 6 ], 'map returns the expected values' ); like( exception { $obj->map }, qr/Cannot call map without at least 1 argument/, 'throws an error when passing no arguments to map' ); like( exception { $obj->map( sub { }, 2 ); }, qr/Cannot call map with more than 1 argument/, 'throws an error when passing two arguments to map' ); like( exception { $obj->map( {} ) }, qr/The argument passed to map must be a code reference/, 'throws an error when passing a non coderef to map' ); $obj->_values( [ 1 .. 5 ] ); is_deeply( [ $obj->map_curried ], [ 2 .. 6 ], 'map_curried returns the expected values' ); like( exception { $obj->map_curried( sub { } ); }, qr/Cannot call map with more than 1 argument/, 'throws an error when passing one argument passed to map_curried' ); $obj->_values( [ 2 .. 9 ] ); is_deeply( [ $obj->grep( sub { $_ < 5 } ) ], [ 2 .. 4 ], 'grep returns the expected values' ); like( exception { $obj->grep }, qr/Cannot call grep without at least 1 argument/, 'throws an error when passing no arguments to grep' ); like( exception { $obj->grep( sub { }, 2 ); }, qr/Cannot call grep with more than 1 argument/, 'throws an error when passing two arguments to grep' ); like( exception { $obj->grep( {} ) }, qr/The argument passed to grep must be a code reference/, 'throws an error when passing a non coderef to grep' ); my $overloader = Overloader->new( sub { $_ < 5 } ); is_deeply( [ $obj->grep($overloader) ], [ 2 .. 4 ], 'grep works with obj that overload code dereferencing' ); is_deeply( [ $obj->grep_curried ], [ 2 .. 4 ], 'grep_curried returns the expected values' ); like( exception { $obj->grep_curried( sub { } ); }, qr/Cannot call grep with more than 1 argument/, 'throws an error when passing one argument passed to grep_curried' ); $obj->_values( [ 2, 4, 22, 99, 101, 6 ] ); is( $obj->first( sub { $_ % 2 } ), 99, 'first returns expected value' ); like( exception { $obj->first }, qr/Cannot call first without at least 1 argument/, 'throws an error when passing no arguments to first' ); like( exception { $obj->first( sub { }, 2 ); }, qr/Cannot call first with more than 1 argument/, 'throws an error when passing two arguments to first' ); like( exception { $obj->first( {} ) }, qr/The argument passed to first must be a code reference/, 'throws an error when passing a non coderef to first' ); is( $obj->first_curried, 99, 'first_curried returns expected value' ); like( exception { $obj->first_curried( sub { } ); }, qr/Cannot call first with more than 1 argument/, 'throws an error when passing one argument passed to first_curried' ); is( $obj->first_index( sub { $_ % 2 } ), 3, 'first_index returns expected value' ); like( exception { $obj->first_index }, qr/Cannot call first_index without at least 1 argument/, 'throws an error when passing no arguments to first_index' ); like( exception { $obj->first_index( sub { }, 2 ); }, qr/Cannot call first_index with more than 1 argument/, 'throws an error when passing two arguments to first_index' ); like( exception { $obj->first_index( {} ) }, qr/The argument passed to first_index must be a code reference/, 'throws an error when passing a non coderef to first_index' ); is( $obj->first_index_curried, 3, 'first_index_curried returns expected value' ); like( exception { $obj->first_index_curried( sub { } ); }, qr/Cannot call first_index with more than 1 argument/, 'throws an error when passing one argument passed to first_index_curried' ); $obj->_values( [ 1 .. 4 ] ); is( $obj->join('-'), '1-2-3-4', 'join returns expected result' ); is( $obj->join(q{}), '1234', 'join returns expected result when joining with empty string' ); is( $obj->join( OverloadStr->new(q{}) ), '1234', 'join returns expected result when joining with empty string' ); like( exception { $obj->join }, qr/Cannot call join without at least 1 argument/, 'throws an error when passing no arguments to join' ); like( exception { $obj->join( '-', 2 ) }, qr/Cannot call join with more than 1 argument/, 'throws an error when passing two arguments to join' ); like( exception { $obj->join( {} ) }, qr/The argument passed to join must be a string/, 'throws an error when passing a non string to join' ); is_deeply( [ sort $obj->shuffle ], [ 1 .. 4 ], 'shuffle returns all values (cannot check for a random order)' ); like( exception { $obj->shuffle(2) }, qr/Cannot call shuffle with any arguments/, 'throws an error when passing an argument passed to shuffle' ); $obj->_values( [ 1 .. 4, 2, 5, 3, 7, 3, 3, 1 ] ); is_deeply( [ $obj->uniq ], [ 1 .. 4, 5, 7 ], 'uniq returns expected values (in original order)' ); like( exception { $obj->uniq(2) }, qr/Cannot call uniq with any arguments/, 'throws an error when passing an argument passed to uniq' ); $obj->_values( [ 1 .. 5 ] ); is( $obj->reduce( sub { $_[0] * $_[1] } ), 120, 'reduce returns expected value' ); like( exception { $obj->reduce }, qr/Cannot call reduce without at least 1 argument/, 'throws an error when passing no arguments to reduce' ); like( exception { $obj->reduce( sub { }, 2 ); }, qr/Cannot call reduce with more than 1 argument/, 'throws an error when passing two arguments to reduce' ); like( exception { $obj->reduce( {} ) }, qr/The argument passed to reduce must be a code reference/, 'throws an error when passing a non coderef to reduce' ); is( $obj->reduce_curried, 120, 'reduce_curried returns expected value' ); like( exception { $obj->reduce_curried( sub { } ); }, qr/Cannot call reduce with more than 1 argument/, 'throws an error when passing one argument passed to reduce_curried' ); $obj->_values( [ 1 .. 6 ] ); my $it = $obj->natatime(2); my @nat; while ( my @v = $it->() ) { push @nat, \@v; } is_deeply( [ [ 1, 2 ], [ 3, 4 ], [ 5, 6 ] ], \@nat, 'natatime returns expected iterator' ); @nat = (); $obj->natatime( 2, sub { push @nat, [@_] } ); is_deeply( [ [ 1, 2 ], [ 3, 4 ], [ 5, 6 ] ], \@nat, 'natatime with function returns expected value' ); like( exception { $obj->natatime( {} ) }, qr/The n value passed to natatime must be an integer/, 'throws an error when passing a non integer to natatime' ); like( exception { $obj->natatime( 2, {} ) }, qr/The second argument passed to natatime must be a code reference/, 'throws an error when passing a non code ref to natatime' ); $it = $obj->natatime_curried(); @nat = (); while ( my @v = $it->() ) { push @nat, \@v; } is_deeply( [ [ 1, 2 ], [ 3, 4 ], [ 5, 6 ] ], \@nat, 'natatime_curried returns expected iterator' ); @nat = (); $obj->natatime_curried( sub { push @nat, [@_] } ); is_deeply( [ [ 1, 2 ], [ 3, 4 ], [ 5, 6 ] ], \@nat, 'natatime_curried with function returns expected value' ); like( exception { $obj->natatime_curried( {} ) }, qr/The second argument passed to natatime must be a code reference/, 'throws an error when passing a non code ref to natatime_curried' ); if ( $class->meta->get_attribute('_values')->is_lazy ) { my $obj = $class->new; is( $obj->count, 2, 'count is 2 (lazy init)' ); $obj->_clear_values; is_deeply( [ $obj->elements ], [ 42, 84 ], 'elements contains default with lazy init' ); $obj->_clear_values; $obj->push(2); is_deeply( $obj->_values, [ 42, 84, 2 ], 'push works with lazy init' ); $obj->_clear_values; $obj->unshift( 3, 4 ); is_deeply( $obj->_values, [ 3, 4, 42, 84 ], 'unshift works with lazy init' ); } } $class; } { my ( $class, $handles ) = build_class( isa => 'ArrayRef' ); my $obj = $class->new; with_immutable { is( exception { $obj->accessor( 0, undef ) }, undef, 'can use accessor to set value to undef' ); is( exception { $obj->accessor_curried_1(undef) }, undef, 'can use curried accessor to set value to undef' ); } $class; } done_testing; application_toclass.t100644000767000024 366012200352344 20150 0ustar00etherstaff000000000000Moose-2.1005/t/roles#!/usr/bin/env perl use strict; use warnings; use Test::More; do { package Role::Foo; use Moose::Role; sub foo { } package Consumer::Basic; use Moose; with 'Role::Foo'; package Consumer::Excludes; use Moose; with 'Role::Foo' => { -excludes => 'foo' }; package Consumer::Aliases; use Moose; with 'Role::Foo' => { -alias => { 'foo' => 'role_foo' } }; package Consumer::Overrides; use Moose; with 'Role::Foo'; sub foo { } }; my @basic = Consumer::Basic->meta->role_applications; my @excludes = Consumer::Excludes->meta->role_applications; my @aliases = Consumer::Aliases->meta->role_applications; my @overrides = Consumer::Overrides->meta->role_applications; is(@basic, 1); is(@excludes, 1); is(@aliases, 1); is(@overrides, 1); my $basic = $basic[0]; my $excludes = $excludes[0]; my $aliases = $aliases[0]; my $overrides = $overrides[0]; isa_ok($basic, 'Moose::Meta::Role::Application::ToClass'); isa_ok($excludes, 'Moose::Meta::Role::Application::ToClass'); isa_ok($aliases, 'Moose::Meta::Role::Application::ToClass'); isa_ok($overrides, 'Moose::Meta::Role::Application::ToClass'); is($basic->role, Role::Foo->meta); is($excludes->role, Role::Foo->meta); is($aliases->role, Role::Foo->meta); is($overrides->role, Role::Foo->meta); is($basic->class, Consumer::Basic->meta); is($excludes->class, Consumer::Excludes->meta); is($aliases->class, Consumer::Aliases->meta); is($overrides->class, Consumer::Overrides->meta); is_deeply($basic->get_method_aliases, {}); is_deeply($excludes->get_method_aliases, {}); is_deeply($aliases->get_method_aliases, { foo => 'role_foo' }); is_deeply($overrides->get_method_aliases, {}); is_deeply($basic->get_method_exclusions, []); is_deeply($excludes->get_method_exclusions, ['foo']); is_deeply($aliases->get_method_exclusions, []); is_deeply($overrides->get_method_exclusions, []); done_testing; compose_overloading.t100644000767000024 65212200352344 20131 0ustar00etherstaff000000000000Moose-2.1005/t/rolesuse strict; use warnings; use Test::More; { package Foo; use Moose::Role; use overload q{""} => sub { 42 }, fallback => 1; no Moose::Role; } { package Bar; use Moose; with 'Foo'; no Moose; } my $bar = Bar->new; TODO: { local $TODO = "the special () method isn't properly composed into the class"; is("$bar", 42, 'overloading can be composed'); } done_testing; with_immutable.t100644000767000024 125212200352344 20157 0ustar00etherstaff000000000000Moose-2.1005/t/test_moose#!/usr/bin/perl use strict; use warnings; use Test::Builder::Tester; use Test::More; plan skip_all => 'These tests are only for Test::Builder 0.9x' if Test::Builder->VERSION >= 1.005; use Test::Moose; { package Foo; use Moose; } { package Bar; use Moose; } package main; test_out("ok 1", "not ok 2"); test_fail(+2); my $ret = with_immutable { ok(Foo->meta->is_mutable); } qw(Foo); test_test('with_immutable failure'); ok(!$ret, "one of our tests failed"); test_out("ok 1", "ok 2"); $ret = with_immutable { ok(Bar->meta->find_method_by_name('new')); } qw(Bar); test_test('with_immutable success'); ok($ret, "all tests succeeded"); done_testing; inlining.t100644000767000024 1315112200352344 20224 0ustar00etherstaff000000000000Moose-2.1005/t/type_constraints#!/usr/bin/perl use strict; use warnings; use Test::Fatal; use Test::More; use Moose::Util::TypeConstraints; #<<< subtype 'Inlinable', as 'Str', where { $_ !~ /Q/ }, inline_as { "defined $_[1] && ! ref $_[1] && $_[1] !~ /Q/" }; subtype 'NotInlinable', as 'Str', where { $_ !~ /Q/ }; #>>> my $inlinable = find_type_constraint('Inlinable'); my $not_inlinable = find_type_constraint('NotInlinable'); { ok( $inlinable->can_be_inlined, 'Inlinable returns true for can_be_inlined' ); is( $inlinable->_inline_check('$foo'), '( do { defined $foo && ! ref $foo && $foo !~ /Q/ } )', 'got expected inline code for Inlinable constraint' ); ok( !$not_inlinable->can_be_inlined, 'NotInlinable returns false for can_be_inlined' ); like( exception { $not_inlinable->_inline_check('$foo') }, qr/Cannot inline a type constraint check for NotInlinable/, 'threw an exception when asking for inlinable code from type which cannot be inlined' ); } { my $aofi = Moose::Util::TypeConstraints::find_or_create_type_constraint( 'ArrayRef[Inlinable]'); ok( $aofi->can_be_inlined, 'ArrayRef[Inlinable] returns true for can_be_inlined' ); is( $aofi->_inline_check('$foo'), q{( do { do {my $check = $foo;ref($check) eq "ARRAY" && &List::MoreUtils::all(sub { ( do { defined $_ && ! ref $_ && $_ !~ /Q/ } ) }, @{$check})} } )}, 'got expected inline code for ArrayRef[Inlinable] constraint' ); my $aofni = Moose::Util::TypeConstraints::find_or_create_type_constraint( 'ArrayRef[NotInlinable]'); ok( !$aofni->can_be_inlined, 'ArrayRef[NotInlinable] returns false for can_be_inlined' ); } subtype 'ArrayOfInlinable', as 'ArrayRef[Inlinable]'; subtype 'ArrayOfNotInlinable', as 'ArrayRef[NotInlinable]'; { my $aofi = Moose::Util::TypeConstraints::find_or_create_type_constraint( 'ArrayOfInlinable'); ok( $aofi->can_be_inlined, 'ArrayOfInlinable returns true for can_be_inlined' ); is( $aofi->_inline_check('$foo'), q{( do { do {my $check = $foo;ref($check) eq "ARRAY" && &List::MoreUtils::all(sub { ( do { defined $_ && ! ref $_ && $_ !~ /Q/ } ) }, @{$check})} } )}, 'got expected inline code for ArrayOfInlinable constraint' ); my $aofni = Moose::Util::TypeConstraints::find_or_create_type_constraint( 'ArrayOfNotInlinable'); ok( !$aofni->can_be_inlined, 'ArrayOfNotInlinable returns false for can_be_inlined' ); } { my $hoaofi = Moose::Util::TypeConstraints::find_or_create_type_constraint( 'HashRef[ArrayRef[Inlinable]]'); ok( $hoaofi->can_be_inlined, 'HashRef[ArrayRef[Inlinable]] returns true for can_be_inlined' ); is( $hoaofi->_inline_check('$foo'), q{( do { do {my $check = $foo;ref($check) eq "HASH" && &List::MoreUtils::all(sub { ( do { do {my $check = $_;ref($check) eq "ARRAY" && &List::MoreUtils::all(sub { ( do { defined $_ && ! ref $_ && $_ !~ /Q/ } ) }, @{$check})} } ) }, values %{$check})} } )}, 'got expected inline code for HashRef[ArrayRef[Inlinable]] constraint' ); my $hoaofni = Moose::Util::TypeConstraints::find_or_create_type_constraint( 'HashRef[ArrayRef[NotInlinable]]'); ok( !$hoaofni->can_be_inlined, 'HashRef[ArrayRef[NotInlinable]] returns false for can_be_inlined' ); } { my $iunion = Moose::Util::TypeConstraints::find_or_create_type_constraint( 'Inlinable | Object'); ok( $iunion->can_be_inlined, 'Inlinable | Object returns true for can_be_inlined' ); is( $iunion->_inline_check('$foo'), '((( do { defined $foo && ! ref $foo && $foo !~ /Q/ } )) || (( do { Scalar::Util::blessed($foo) } )))', 'got expected inline code for Inlinable | Object constraint' ); my $niunion = Moose::Util::TypeConstraints::find_or_create_type_constraint( 'NotInlinable | Object'); ok( !$niunion->can_be_inlined, 'NotInlinable | Object returns false for can_be_inlined' ); } { my $iunion = Moose::Util::TypeConstraints::find_or_create_type_constraint( 'Object | Inlinable'); ok( $iunion->can_be_inlined, 'Object | Inlinable returns true for can_be_inlined' ); is( $iunion->_inline_check('$foo'), '((( do { Scalar::Util::blessed($foo) } )) || (( do { defined $foo && ! ref $foo && $foo !~ /Q/ } )))', 'got expected inline code for Object | Inlinable constraint' ); my $niunion = Moose::Util::TypeConstraints::find_or_create_type_constraint( 'Object | NotInlinable'); ok( !$niunion->can_be_inlined, 'Object | NotInlinable returns false for can_be_inlined' ); } { my $iunion = Moose::Util::TypeConstraints::find_or_create_type_constraint( 'Object | Inlinable | CodeRef'); ok( $iunion->can_be_inlined, 'Object | Inlinable | CodeRef returns true for can_be_inlined' ); is( $iunion->_inline_check('$foo'), q{((( do { Scalar::Util::blessed($foo) } )) || (( do { defined $foo && ! ref $foo && $foo !~ /Q/ } )) || (( do { ref($foo) eq "CODE" } )))}, 'got expected inline code for Object | Inlinable | CodeRef constraint' ); my $niunion = Moose::Util::TypeConstraints::find_or_create_type_constraint( 'Object | NotInlinable | CodeRef'); ok( !$niunion->can_be_inlined, 'Object | NotInlinable | CodeRef returns false for can_be_inlined' ); } done_testing; method_modifiers.pl100755000767000024 464112200352344 20337 0ustar00etherstaff000000000000Moose-2.1005/benchmarks#!perl ### MODULES { package PlainParent; sub new { bless {} => shift } sub method { "P" } } { package MooseParent; use Moose; sub method { "P" } } { package CMMChild::Before; use Class::Method::Modifiers; use base 'PlainParent'; before method => sub { "B" }; } { package MooseBefore; use Moose; extends 'MooseParent'; before method => sub { "B" }; } { package CMMChild::Around; use Class::Method::Modifiers; use base 'PlainParent'; around method => sub { shift->() . "A" }; } { package MooseAround; use Moose; extends 'MooseParent'; around method => sub { shift->() . "A" }; } { package CMMChild::AllThree; use Class::Method::Modifiers; use base 'PlainParent'; before method => sub { "B" }; around method => sub { shift->() . "A" }; after method => sub { "Z" }; } { package MooseAllThree; use Moose; extends 'MooseParent'; before method => sub { "B" }; around method => sub { shift->() . "A" }; after method => sub { "Z" }; } { package CMM::Install; use Class::Method::Modifiers; use base 'PlainParent'; } { package Moose::Install; use Moose; extends 'MooseParent'; } use Benchmark qw(cmpthese); use Benchmark ':hireswallclock'; my $rounds = -5; my $cmm_before = CMMChild::Before->new(); my $cmm_around = CMMChild::Around->new(); my $cmm_allthree = CMMChild::AllThree->new(); my $moose_before = MooseBefore->new(); my $moose_around = MooseAround->new(); my $moose_allthree = MooseAllThree->new(); print "\nBEFORE\n"; cmpthese($rounds, { Moose => sub { $moose_before->method() }, ClassMethodModifiers => sub { $cmm_before->method() }, }, 'noc'); print "\nAROUND\n"; cmpthese($rounds, { Moose => sub { $moose_around->method() }, ClassMethodModifiers => sub { $cmm_around->method() }, }, 'noc'); print "\nALL THREE\n"; cmpthese($rounds, { Moose => sub { $moose_allthree->method() }, ClassMethodModifiers => sub { $cmm_allthree->method() }, }, 'noc'); print "\nINSTALL AROUND\n"; cmpthese($rounds, { Moose => sub { package Moose::Install; Moose::Install::around(method => sub {}); }, ClassMethodModifiers => sub { package CMM::Install; CMM::Install::around(method => sub {}); }, }, 'noc'); type_constraints.pl100600000767000024 145612200352344 20414 0ustar00etherstaff000000000000Moose-2.1005/benchmarks#!/usr/bin/perl use strict; use warnings; use Benchmark qw[cmpthese]; =pod This benchmark compares the overhead of a auto-created type constraint vs. none at all vs. a custom-created type. =cut { package Foo; use Moose; use Moose::Util::TypeConstraints; has 'baz' => (is => 'rw'); has 'bar' => (is => 'rw', isa => 'Foo'); } { package Bar; sub new { bless {} => __PACKAGE__ } sub bar { my $self = shift; $self->{bar} = shift if @_; $self->{bar}; } } my $foo = Foo->new; my $bar = Bar->new; cmpthese(200_000, { 'hand coded' => sub { $bar->bar($bar); }, 'w/out_constraint' => sub { $foo->baz($foo); }, 'w_constraint' => sub { $foo->bar($foo); }, } ); 1;ArrayBasedStorage.pod100644000767000024 566312200352344 20232 0ustar00etherstaff000000000000Moose-2.1005/examples package # hide the package from PAUSE ArrayBasedStorage::Instance; use strict; use warnings; use Scalar::Util qw/refaddr/; use Carp 'confess'; our $VERSION = '0.01'; my $unbound = \'empty-slot-value'; use base 'Class::MOP::Instance'; sub new { my ($class, $meta, @attrs) = @_; my $self = $class->SUPER::new($meta, @attrs); my $index = 0; $self->{'slot_index_map'} = { map { $_ => $index++ } $self->get_all_slots }; return $self; } sub create_instance { my $self = shift; my $instance = bless [], $self->_class_name; $self->initialize_all_slots($instance); return $instance; } sub clone_instance { my ($self, $instance) = shift; $self->bless_instance_structure([ @$instance ]); } # operations on meta instance sub get_slot_index_map { (shift)->{'slot_index_map'} } sub initialize_slot { my ($self, $instance, $slot_name) = @_; $self->set_slot_value($instance, $slot_name, $unbound); } sub deinitialize_slot { my ( $self, $instance, $slot_name ) = @_; $self->set_slot_value($instance, $slot_name, $unbound); } sub get_all_slots { my $self = shift; return sort $self->SUPER::get_all_slots; } sub get_slot_value { my ($self, $instance, $slot_name) = @_; my $value = $instance->[ $self->{'slot_index_map'}->{$slot_name} ]; return $value unless ref $value; refaddr $value eq refaddr $unbound ? undef : $value; } sub set_slot_value { my ($self, $instance, $slot_name, $value) = @_; $instance->[ $self->{'slot_index_map'}->{$slot_name} ] = $value; } sub is_slot_initialized { my ($self, $instance, $slot_name) = @_; # NOTE: maybe use CLOS's *special-unbound-value* for this? my $value = $instance->[ $self->{'slot_index_map'}->{$slot_name} ]; return 1 unless ref $value; refaddr $value eq refaddr $unbound ? 0 : 1; } sub is_dependent_on_superclasses { 1 } 1; __END__ =pod =head1 NAME ArrayBasedStorage - An example of an Array based instance storage =head1 SYNOPSIS package Foo; use metaclass ( ':instance_metaclass' => 'ArrayBasedStorage::Instance' ); __PACKAGE__->meta->add_attribute('foo' => ( reader => 'get_foo', writer => 'set_foo' )); sub new { my $class = shift; $class->meta->new_object(@_); } # now you can just use the class as normal =head1 DESCRIPTION This is a proof of concept using the Instance sub-protocol which uses ARRAY refs to store the instance data. This is very similar now to the InsideOutClass example, and in fact, they both share the exact same test suite, with the only difference being the Instance metaclass they use. =head1 AUTHORS Stevan Little Estevan@iinteractive.comE Yuval Kogman Enothingmuch@woobling.comE =head1 SEE ALSO =head1 COPYRIGHT AND LICENSE Copyright 2006-2008 by Infinity Interactive, Inc. L This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut TypeCoercion.pm100644000767000024 1177612200352344 20047 0ustar00etherstaff000000000000Moose-2.1005/lib/Moose/Meta package Moose::Meta::TypeCoercion; BEGIN { $Moose::Meta::TypeCoercion::AUTHORITY = 'cpan:STEVAN'; } { $Moose::Meta::TypeCoercion::VERSION = '2.1005'; } use strict; use warnings; use metaclass; use Moose::Meta::Attribute; use Moose::Util::TypeConstraints (); __PACKAGE__->meta->add_attribute('type_coercion_map' => ( reader => 'type_coercion_map', default => sub { [] }, Class::MOP::_definition_context(), )); __PACKAGE__->meta->add_attribute( Moose::Meta::Attribute->new('type_constraint' => ( reader => 'type_constraint', weak_ref => 1, Class::MOP::_definition_context(), )) ); # private accessor __PACKAGE__->meta->add_attribute('compiled_type_coercion' => ( accessor => '_compiled_type_coercion', Class::MOP::_definition_context(), )); sub new { my $class = shift; my $self = Class::MOP::class_of($class)->new_object(@_); $self->compile_type_coercion; return $self; } sub compile_type_coercion { my $self = shift; my @coercion_map = @{$self->type_coercion_map}; my @coercions; while (@coercion_map) { my ($constraint_name, $action) = splice(@coercion_map, 0, 2); my $type_constraint = ref $constraint_name ? $constraint_name : Moose::Util::TypeConstraints::find_or_parse_type_constraint($constraint_name); unless ( defined $type_constraint ) { require Moose; Moose->throw_error("Could not find the type constraint ($constraint_name) to coerce from"); } push @coercions => [ $type_constraint->_compiled_type_constraint, $action ]; } $self->_compiled_type_coercion(sub { my $thing = shift; foreach my $coercion (@coercions) { my ($constraint, $converter) = @$coercion; if ($constraint->($thing)) { local $_ = $thing; return $converter->($thing); } } return $thing; }); } sub has_coercion_for_type { my ($self, $type_name) = @_; my %coercion_map = @{$self->type_coercion_map}; exists $coercion_map{$type_name} ? 1 : 0; } sub add_type_coercions { my ($self, @new_coercion_map) = @_; my $coercion_map = $self->type_coercion_map; my %has_coercion = @$coercion_map; while (@new_coercion_map) { my ($constraint_name, $action) = splice(@new_coercion_map, 0, 2); if ( exists $has_coercion{$constraint_name} ) { require Moose; Moose->throw_error("A coercion action already exists for '$constraint_name'") } push @{$coercion_map} => ($constraint_name, $action); } # and re-compile ... $self->compile_type_coercion; } sub coerce { $_[0]->_compiled_type_coercion->($_[1]) } 1; # ABSTRACT: The Moose Type Coercion metaclass __END__ =pod =head1 NAME Moose::Meta::TypeCoercion - The Moose Type Coercion metaclass =head1 VERSION version 2.1005 =head1 DESCRIPTION A type coercion object is basically a mapping of one or more type constraints and the associated coercions subroutines. It's unlikely that you will need to instantiate an object of this class directly, as it's part of the deep internals of Moose. =head1 METHODS =over 4 =item B<< Moose::Meta::TypeCoercion->new(%options) >> Creates a new type coercion object, based on the options provided. =over 8 =item * type_constraint This is the L object for the type that is being coerced I. =back =item B<< $coercion->type_coercion_map >> This returns the map of type constraints to coercions as an array reference. The values of the array alternate between type names and subroutine references which implement the coercion. The value is an array reference because coercions are tried in the order they are added. =item B<< $coercion->type_constraint >> This returns the L that was passed to the constructor. =item B<< $coercion->has_coercion_for_type($type_name) >> Returns true if the coercion can coerce the named type. =item B<< $coercion->add_type_coercions( $type_name => $sub, ... ) >> This method takes a list of type names and subroutine references. If the coercion already has a mapping for a given type, it throws an exception. Coercions are actually =item B<< $coercion->coerce($value) >> This method takes a value and applies the first valid coercion it finds. This means that if the value could belong to more than type in the coercion object, the first coercion added is used. =item B<< Moose::Meta::TypeCoercion->meta >> This will return a L instance for this class. =back =head1 BUGS See L for details on reporting bugs. =head1 AUTHOR Moose is maintained by the Moose Cabal, along with the help of many contributors. See L and L for details. =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2013 by Infinity Interactive, Inc.. This is free software; you can redistribute it and/or modify it under the same terms as the Perl 5 programming language system itself. =cut Object000755000767000024 012200352344 16120 5ustar00etherstaff000000000000Moose-2.1005/lib/Moose/MetaTrait.pm100644000767000024 276712200352344 17715 0ustar00etherstaff000000000000Moose-2.1005/lib/Moose/Meta/Object package Moose::Meta::Object::Trait; BEGIN { $Moose::Meta::Object::Trait::AUTHORITY = 'cpan:STEVAN'; } { $Moose::Meta::Object::Trait::VERSION = '2.1005'; } use Scalar::Util qw(blessed); sub _get_compatible_metaclass { my $orig = shift; my $self = shift; return $self->$orig(@_) || $self->_get_compatible_metaclass_by_role_reconciliation(@_); } sub _get_compatible_metaclass_by_role_reconciliation { my $self = shift; my ($other_name) = @_; my $meta_name = blessed($self) ? $self->_real_ref_name : $self; return unless Moose::Util::_classes_differ_by_roles_only( $meta_name, $other_name ); return Moose::Util::_reconcile_roles_for_metaclass( $meta_name, $other_name ); } 1; # ABSTRACT: Some overrides for L functionality __END__ =pod =head1 NAME Moose::Meta::Object::Trait - Some overrides for L functionality =head1 VERSION version 2.1005 =head1 DESCRIPTION This module is entirely private, you shouldn't ever need to interact with it directly. =head1 BUGS See L for details on reporting bugs. =head1 AUTHOR Moose is maintained by the Moose Cabal, along with the help of many contributors. See L and L for details. =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2013 by Infinity Interactive, Inc.. This is free software; you can redistribute it and/or modify it under the same terms as the Perl 5 programming language system itself. =cut attribute_names.t100644000767000024 205712200352344 20344 0ustar00etherstaff000000000000Moose-2.1005/t/attributes#!/usr/bin/perl use strict; use warnings; use Test::More; use Test::Fatal; my $exception_regex = qr/You must provide a name for the attribute/; { package My::Role; use Moose::Role; ::like( ::exception { has; }, $exception_regex, 'has; fails' ); ::like( ::exception { has undef; }, $exception_regex, 'has undef; fails' ); ::is( ::exception { has "" => ( is => 'bare', ); }, undef, 'has ""; works now' ); ::is( ::exception { has 0 => ( is => 'bare', ); }, undef, 'has 0; works now' ); } { package My::Class; use Moose; ::like( ::exception { has; }, $exception_regex, 'has; fails' ); ::like( ::exception { has undef; }, $exception_regex, 'has undef; fails' ); ::is( ::exception { has "" => ( is => 'bare', ); }, undef, 'has ""; works now' ); ::is( ::exception { has 0 => ( is => 'bare', ); }, undef, 'has 0; works now' ); } done_testing; lazy_no_default.t100644000767000024 65212200352344 20314 0ustar00etherstaff000000000000Moose-2.1005/t/attributes#!/usr/bin/perl use strict; use warnings; use Test::More; use Test::Fatal; { package Foo; use Moose; ::like( ::exception{ has foo => ( is => 'ro', lazy => 1, ); }, qr/\QYou cannot have a lazy attribute (foo) without specifying a default value for it/, 'lazy without a default or builder throws an error' ); } done_testing; super_warns_on_args.t100644000767000024 127112200352344 20311 0ustar00etherstaff000000000000Moose-2.1005/t/basicsuse strict; use warnings; use Test::Requires { 'Test::Output' => '0.01', }; use Test::More; { package Parent; use Moose; sub foo { 42 } sub bar { 42 } package Child; use Moose; extends 'Parent'; override foo => sub { super( 1, 2, 3 ); }; override bar => sub { super(); }; } { my $file = __FILE__; stderr_like( sub { Child->new->foo }, qr/\QArguments passed to super() are ignored at $file/, 'got a warning when passing args to super() call' ); stderr_is( sub { Child->new->bar }, q{}, 'no warning on super() call without arguments' ); } done_testing(); anon_method_metaclass.t100644000767000024 232612200352344 20256 0ustar00etherstaff000000000000Moose-2.1005/t/bugsuse strict; use warnings; use Test::More; { package Ball; use Moose; } { package Arbitrary::Roll; use Moose::Role; } my $method_meta = Moose::Meta::Class->create_anon_class( superclasses => ['Moose::Meta::Method'], roles => ['Arbitrary::Roll'], ); # For comparing identity without actually keeping $original_meta around my $original_meta = "$method_meta"; my $method_class = $method_meta->name; my $method_object = $method_class->wrap( sub {'ok'}, associated_metaclass => Ball->meta, package_name => 'Ball', name => 'bounce', ); Ball->meta->add_method( bounce => $method_object ); for ( 1, 2 ) { is( Ball->bounce, 'ok', "method still exists on Ball" ); is( Ball->meta->get_method('bounce')->meta->name, $method_class, "method's package still exists" ); is( Ball->meta->get_method('bounce'), $method_object, 'original method object is preserved' ); is( Ball->meta->get_method('bounce')->meta . '', $original_meta, "method's metaclass still exists" ); ok( Ball->meta->get_method('bounce')->meta->does_role('Arbitrary::Roll'), "method still does Arbitrary::Roll" ); undef $method_meta; } done_testing; augment_recursion_bug.t100644000767000024 164712200352344 20322 0ustar00etherstaff000000000000Moose-2.1005/t/bugs#!/usr/bin/perl use strict; use warnings; use Test::More; { package Foo; use Moose; sub foo { 'Foo::foo(' . (inner() || '') . ')' }; package Bar; use Moose; extends 'Foo'; package Baz; use Moose; extends 'Foo'; my $foo_call_counter; augment 'foo' => sub { die "infinite loop on Baz::foo" if $foo_call_counter++ > 1; return 'Baz::foo and ' . Bar->new->foo; }; } my $baz = Baz->new(); isa_ok($baz, 'Baz'); isa_ok($baz, 'Foo'); =pod When a subclass which augments foo(), calls a subclass which does not augment foo(), there is a chance for some confusion. If Moose does not realize that Bar does not augment foo(), because it is in the call flow of Baz which does, then we may have an infinite loop. =cut is($baz->foo, 'Foo::foo(Baz::foo and Foo::foo())', '... got the right value for 1 augmented subclass calling non-augmented subclass'); done_testing; create_anon_recursion.t100644000767000024 110612200352344 20271 0ustar00etherstaff000000000000Moose-2.1005/t/bugsuse strict; use warnings; use Test::More; use Test::Fatal; BEGIN { plan skip_all => "preloading things makes this test meaningless" if exists $INC{'Moose.pm'}; } use Moose::Meta::Class; $SIG{__WARN__} = sub { die if shift =~ /recurs/ }; TODO: { local $TODO = 'Loading Moose::Meta::Class without loading Moose.pm causes weird problems'; my $meta; is( exception { $meta = Moose::Meta::Class->create_anon_class( superclasses => [ 'Moose::Object', ], ); }, undef, 'Class is created successfully' ); } done_testing; inheriting_from_roles.t100644000767000024 51512200352344 20274 0ustar00etherstaff000000000000Moose-2.1005/t/bugs#!/usr/bin/perl use strict; use warnings; use Test::More; use Test::Fatal; { package My::Role; use Moose::Role; } { package My::Class; use Moose; ::like( ::exception { extends 'My::Role'; }, qr/You cannot inherit from a Moose Role \(My\:\:Role\)/, '... this croaks correctly' ); } done_testing; reader_precedence_bug.t100644000767000024 65612200352344 20167 0ustar00etherstaff000000000000Moose-2.1005/t/bugs#!/usr/bin/perl use strict; use warnings; use Test::More; { package Foo; use Moose; has 'foo' => ( is => 'ro', reader => 'get_foo' ); } { my $foo = Foo->new(foo => 10); my $reader = $foo->meta->get_attribute('foo')->reader; is($reader, 'get_foo', 'reader => "get_foo" has correct presedence'); can_ok($foo, 'get_foo'); is($foo->$reader, 10, "Reader works as expected"); } done_testing; subclass_use_base_bug.t100644000767000024 52612200352344 20231 0ustar00etherstaff000000000000Moose-2.1005/t/bugs#!/usr/bin/perl use strict; use warnings; use Test::More; =pod This just makes sure that the Bar gets a metaclass initialized for it correctly. =cut { package Foo; use Moose; package Bar; use strict; use warnings; use base 'Foo'; } my $bar = Bar->new; isa_ok($bar, 'Bar'); isa_ok($bar, 'Foo'); done_testing; anon_class_keep_alive.t100644000767000024 272412200352344 20233 0ustar00etherstaff000000000000Moose-2.1005/t/cmopuse strict; use warnings; use Test::More; use Test::Fatal; use Class::MOP; my $anon_class_name; my $anon_meta_name; { package Foo; use strict; use warnings; use metaclass; sub make_anon_instance{ my $self = shift; my $class = ref $self || $self; my $anon_class = Class::MOP::Class->create_anon_class(superclasses => [$class]); $anon_class_name = $anon_class->name; $anon_meta_name = Scalar::Util::blessed($anon_class); $anon_class->add_attribute( $_, reader => $_ ) for qw/bar baz/; my $obj = $anon_class->new_object(bar => 'a', baz => 'b'); return $obj; } sub foo{ 'foo' } 1; } my $instance = Foo->make_anon_instance; isa_ok($instance, $anon_class_name); isa_ok($instance->meta, $anon_meta_name); isa_ok($instance, 'Foo', '... Anonymous instance isa Foo'); ok($instance->can('foo'), '... Anonymous instance can foo'); ok($instance->meta->find_method_by_name('foo'), '... Anonymous instance has method foo'); ok($instance->meta->has_attribute('bar'), '... Anonymous instance still has attribute bar'); ok($instance->meta->has_attribute('baz'), '... Anonymous instance still has attribute baz'); is($instance->bar, 'a', '... Anonymous instance still has correct bar value'); is($instance->baz, 'b', '... Anonymous instance still has correct baz value'); is_deeply([$instance->meta->class_precedence_list], [$anon_class_name, 'Foo'], '... Anonymous instance has class precedence list', ); done_testing; attribute_duplication.t100644000767000024 350012200352344 20316 0ustar00etherstaff000000000000Moose-2.1005/t/cmopuse strict; use warnings; use Scalar::Util; use Test::More; use Class::MOP; =pod This tests that when an attribute of the same name is added to a class, that it will remove the old one first. =cut { package Foo; use metaclass; Foo->meta->add_attribute('bar' => reader => 'get_bar', writer => 'set_bar', ); ::can_ok('Foo', 'get_bar'); ::can_ok('Foo', 'set_bar'); ::ok(Foo->meta->has_attribute('bar'), '... Foo has the attribute bar'); my $bar_attr = Foo->meta->get_attribute('bar'); ::is($bar_attr->reader, 'get_bar', '... the bar attribute has the reader get_bar'); ::is($bar_attr->writer, 'set_bar', '... the bar attribute has the writer set_bar'); ::is($bar_attr->associated_class, Foo->meta, '... and the bar attribute is associated with Foo->meta'); Foo->meta->add_attribute('bar' => reader => 'assign_bar' ); ::ok(!Foo->can('get_bar'), '... Foo no longer has the get_bar method'); ::ok(!Foo->can('set_bar'), '... Foo no longer has the set_bar method'); ::can_ok('Foo', 'assign_bar'); ::ok(Foo->meta->has_attribute('bar'), '... Foo still has the attribute bar'); my $bar_attr2 = Foo->meta->get_attribute('bar'); ::isnt($bar_attr, $bar_attr2, '... this is a new bar attribute'); ::isnt($bar_attr->associated_class, Foo->meta, '... and the old bar attribute is no longer associated with Foo->meta'); ::is($bar_attr2->associated_class, Foo->meta, '... and the new bar attribute *is* associated with Foo->meta'); ::isnt($bar_attr2->reader, 'get_bar', '... the bar attribute no longer has the reader get_bar'); ::isnt($bar_attr2->reader, 'set_bar', '... the bar attribute no longer has the reader set_bar'); ::is($bar_attr2->reader, 'assign_bar', '... the bar attribute now has the reader assign_bar'); } done_testing; attribute_initializer.t100644000767000024 210212200352344 20323 0ustar00etherstaff000000000000Moose-2.1005/t/cmopuse strict; use warnings; use Scalar::Util 'blessed', 'reftype'; use Test::More; use Class::MOP; =pod This checks that the initializer is used to set the initial value. =cut { package Foo; use metaclass; Foo->meta->add_attribute('bar' => reader => 'get_bar', writer => 'set_bar', initializer => sub { my ($self, $value, $callback, $attr) = @_; ::isa_ok($attr, 'Class::MOP::Attribute'); ::is($attr->name, 'bar', '... the attribute is our own'); $callback->($value * 2); }, ); } can_ok('Foo', 'get_bar'); can_ok('Foo', 'set_bar'); my $foo = Foo->meta->new_object(bar => 10); is($foo->get_bar, 20, "... initial argument was doubled as expected"); $foo->set_bar(30); is($foo->get_bar, 30, "... and setter works correctly"); # meta tests ... my $bar = Foo->meta->get_attribute('bar'); isa_ok($bar, 'Class::MOP::Attribute'); ok($bar->has_initializer, '... bar has an initializer'); is(reftype $bar->initializer, 'CODE', '... the initializer is a CODE ref'); done_testing; class_precedence_list.t100644000767000024 541312200352344 20242 0ustar00etherstaff000000000000Moose-2.1005/t/cmopuse strict; use warnings; use Test::More; use Class::MOP; use Class::MOP::Class; =pod A / \ B C \ / D =cut { package My::A; use metaclass; package My::B; our @ISA = ('My::A'); package My::C; our @ISA = ('My::A'); package My::D; our @ISA = ('My::B', 'My::C'); } is_deeply( [ My::D->meta->class_precedence_list ], [ 'My::D', 'My::B', 'My::A', 'My::C', 'My::A' ], '... My::D->meta->class_precedence_list == (D B A C A)'); is_deeply( [ My::D->meta->linearized_isa ], [ 'My::D', 'My::B', 'My::A', 'My::C' ], '... My::D->meta->linearized_isa == (D B A C)'); =pod A <-+ | | B | | | C --+ =cut # 5.9.5+ dies at the moment of # recursive @ISA definition, not later when # you try to use the @ISAs. eval { { package My::2::A; use metaclass; our @ISA = ('My::2::C'); package My::2::B; our @ISA = ('My::2::A'); package My::2::C; our @ISA = ('My::2::B'); } My::2::B->meta->class_precedence_list }; ok($@, '... recursive inheritance breaks correctly :)'); =pod +--------+ | A | | / \ | +->B C-+ \ / D =cut { package My::3::A; use metaclass; package My::3::B; our @ISA = ('My::3::A'); package My::3::C; our @ISA = ('My::3::A', 'My::3::B'); package My::3::D; our @ISA = ('My::3::B', 'My::3::C'); } is_deeply( [ My::3::D->meta->class_precedence_list ], [ 'My::3::D', 'My::3::B', 'My::3::A', 'My::3::C', 'My::3::A', 'My::3::B', 'My::3::A' ], '... My::3::D->meta->class_precedence_list == (D B A C A B A)'); is_deeply( [ My::3::D->meta->linearized_isa ], [ 'My::3::D', 'My::3::B', 'My::3::A', 'My::3::C' ], '... My::3::D->meta->linearized_isa == (D B A C B)'); =pod Test all the class_precedence_lists using Perl's own dispatcher to check against. =cut my @CLASS_PRECEDENCE_LIST; { package Foo; use metaclass; sub CPL { push @CLASS_PRECEDENCE_LIST => 'Foo' } package Bar; our @ISA = ('Foo'); sub CPL { push @CLASS_PRECEDENCE_LIST => 'Bar'; $_[0]->SUPER::CPL(); } package Baz; use metaclass; our @ISA = ('Bar'); sub CPL { push @CLASS_PRECEDENCE_LIST => 'Baz'; $_[0]->SUPER::CPL(); } package Foo::Bar; our @ISA = ('Baz'); sub CPL { push @CLASS_PRECEDENCE_LIST => 'Foo::Bar'; $_[0]->SUPER::CPL(); } package Foo::Bar::Baz; our @ISA = ('Foo::Bar'); sub CPL { push @CLASS_PRECEDENCE_LIST => 'Foo::Bar::Baz'; $_[0]->SUPER::CPL(); } } Foo::Bar::Baz->CPL(); is_deeply( [ Foo::Bar::Baz->meta->class_precedence_list ], [ @CLASS_PRECEDENCE_LIST ], '... Foo::Bar::Baz->meta->class_precedence_list == @CLASS_PRECEDENCE_LIST'); done_testing; metaclass_inheritance.t100644000767000024 157412200352344 20256 0ustar00etherstaff000000000000Moose-2.1005/t/cmopuse strict; use warnings; use Test::More; use Test::Fatal; use Class::MOP; =pod Test that a default set up will cause metaclasses to inherit the same metaclass type, but produce different metaclasses. =cut { package Foo; use metaclass; package Bar; use base 'Foo'; package Baz; use base 'Bar'; } my $foo_meta = Foo->meta; isa_ok($foo_meta, 'Class::MOP::Class'); is($foo_meta->name, 'Foo', '... foo_meta->name == Foo'); my $bar_meta = Bar->meta; isa_ok($bar_meta, 'Class::MOP::Class'); is($bar_meta->name, 'Bar', '... bar_meta->name == Bar'); isnt($bar_meta, $foo_meta, '... Bar->meta != Foo->meta'); my $baz_meta = Baz->meta; isa_ok($baz_meta, 'Class::MOP::Class'); is($baz_meta->name, 'Baz', '... baz_meta->name == Baz'); isnt($baz_meta, $bar_meta, '... Baz->meta != Bar->meta'); isnt($baz_meta, $foo_meta, '... Baz->meta != Foo->meta'); done_testing; rebless_instance_away.t100644000767000024 173312200352344 20272 0ustar00etherstaff000000000000Moose-2.1005/t/cmop#!/usr/bin/env perl use strict; use warnings; use Test::More; use Class::MOP; my @calls; do { package My::Meta::Class; use base 'Class::MOP::Class'; sub rebless_instance_away { push @calls, [@_]; shift->SUPER::rebless_instance_away(@_); } }; do { package Parent; use metaclass 'My::Meta::Class'; package Child; use metaclass 'My::Meta::Class'; use base 'Parent'; }; my $person = Parent->meta->new_object; Child->meta->rebless_instance($person); is(@calls, 1, "one call to rebless_instance_away"); is($calls[0][0]->name, 'Parent', 'rebless_instance_away is called on the old metaclass'); is($calls[0][1], $person, 'with the instance'); is($calls[0][2]->name, 'Child', 'and the new metaclass'); splice @calls; Child->meta->rebless_instance($person, foo => 1); is($calls[0][0]->name, 'Child'); is($calls[0][1], $person); is($calls[0][2]->name, 'Child'); is($calls[0][3], 'foo'); is($calls[0][4], 1); splice @calls; done_testing; compat000755000767000024 012200352344 13722 5ustar00etherstaff000000000000Moose-2.1005/tcomposite_metaroles.t100755000767000024 154112200352344 20330 0ustar00etherstaff000000000000Moose-2.1005/t/compat#!/usr/bin/env perl use strict; use warnings; use Test::More; use Test::Fatal; use Test::Moose; { package Foo::Role; use Moose::Role; } { package Bar::Role; use Moose::Role; } { package Parent; use Moose; Moose::Util::MetaRole::apply_metaroles( for => __PACKAGE__, class_metaroles => { class => ['Foo::Role'] }, ); } { package Child; use Moose; Moose::Util::MetaRole::apply_metaroles( for => __PACKAGE__, class_metaroles => { class => ['Foo::Role', 'Bar::Role'] }, ); ::is( ::exception { extends 'Parent' }, undef ); } with_immutable { isa_ok('Child', 'Parent'); isa_ok(Child->meta, Parent->meta->_real_ref_name); does_ok(Parent->meta, 'Foo::Role'); does_ok(Child->meta, 'Foo::Role'); does_ok(Child->meta, 'Bar::Role'); } 'Parent', 'Child'; done_testing; foreign_inheritence.t100644000767000024 357012200352344 20262 0ustar00etherstaff000000000000Moose-2.1005/t/compat#!/usr/bin/perl use strict; use warnings; use Test::More; use Test::Fatal; { package Elk; use strict; use warnings; sub new { my $class = shift; bless { no_moose => "Elk" } => $class; } sub no_moose { $_[0]->{no_moose} } package Foo::Moose; use Moose; extends 'Elk'; has 'moose' => ( is => 'ro', default => 'Foo' ); sub new { my $class = shift; my $super = $class->SUPER::new(@_); return $class->meta->new_object( '__INSTANCE__' => $super, @_ ); } __PACKAGE__->meta->make_immutable( inline_constructor => 0, debug => 0 ); package Bucket; use metaclass 'Class::MOP::Class'; __PACKAGE__->meta->add_attribute( 'squeegee' => ( accessor => 'squeegee' ) ); package Old::Bucket::Nose; # see http://www.moosefoundation.org/moose_facts.htm use Moose; extends 'Bucket'; package MyBase; sub foo { } package Custom::Meta1; use base qw(Moose::Meta::Class); package Custom::Meta2; use base qw(Moose::Meta::Class); package SubClass1; use metaclass 'Custom::Meta1'; use Moose; extends 'MyBase'; package SubClass2; use metaclass 'Custom::Meta2'; use Moose; # XXX FIXME subclassing meta-attrs and immutable-ing the subclass fails } my $foo_moose = Foo::Moose->new(); isa_ok( $foo_moose, 'Foo::Moose' ); isa_ok( $foo_moose, 'Elk' ); is( $foo_moose->no_moose, 'Elk', '... got the right value from the Elk method' ); is( $foo_moose->moose, 'Foo', '... got the right value from the Foo::Moose method' ); is( exception { Old::Bucket::Nose->meta->make_immutable( debug => 0 ); }, undef, 'Immutability on Moose class extending Class::MOP class ok' ); is( exception { SubClass2->meta->superclasses('MyBase'); }, undef, 'Can subclass the same non-Moose class twice with different metaclasses' ); done_testing; moose_respects_base.t100644000767000024 136612200352344 20301 0ustar00etherstaff000000000000Moose-2.1005/t/compat#!/usr/bin/perl use strict; use warnings; use Test::More; =pod This test demonstrates that Moose will respect a previously set @ISA using use base, and not try to add Moose::Object to it. However, this is extremely order sensitive as this test also demonstrates. =cut { package Foo; use strict; use warnings; sub foo { 'Foo::foo' } package Bar; use base 'Foo'; use Moose; sub new { (shift)->meta->new_object(@_) } package Baz; use Moose; use base 'Foo'; } my $bar = Bar->new; isa_ok($bar, 'Bar'); isa_ok($bar, 'Foo'); ok(!$bar->isa('Moose::Object'), '... Bar is not Moose::Object subclass'); my $baz = Baz->new; isa_ok($baz, 'Baz'); isa_ok($baz, 'Foo'); isa_ok($baz, 'Moose::Object'); done_testing; inline_fallbacks.t100644000767000024 222212200352344 20221 0ustar00etherstaff000000000000Moose-2.1005/t/immutableuse strict; use warnings; use Test::More; { package Foo; use Moose; has foo => (is => 'ro'); } { package Foo::Sub; use Moose; extends 'Foo'; has bar => (is => 'ro'); } { my $foo = Foo::Sub->new(foo => 12, bar => 25); is($foo->foo, 12, 'got right value for foo'); is($foo->bar, 25, 'got right value for bar'); } Foo->meta->make_immutable; { package Foo::Sub2; use Moose; extends 'Foo'; has baz => (is => 'ro'); # not making immutable, inheriting Foo's inlined constructor } { my $foo = Foo::Sub2->new(foo => 42, baz => 27); is($foo->foo, 42, 'got right value for foo'); is($foo->baz, 27, 'got right value for baz'); } my $BAR = 0; { package Bar; use Moose; } { package Bar::Sub; use Moose; extends 'Bar'; sub DEMOLISH { $BAR++ } } Bar::Sub->new; is($BAR, 1, 'DEMOLISH in subclass was called'); $BAR = 0; Bar->meta->make_immutable; { package Bar::Sub2; use Moose; extends 'Bar'; sub DEMOLISH { $BAR++ } # not making immutable, inheriting Bar's inlined destructor } Bar::Sub2->new; is($BAR, 1, 'DEMOLISH in subclass was called'); done_testing; easy_init_meta.t100644000767000024 545612200352344 20274 0ustar00etherstaff000000000000Moose-2.1005/t/metaclasses#!/usr/bin/perl use strict; use warnings; use Test::More; use Test::Moose qw(does_ok); { package Foo::Trait::Class; use Moose::Role; } { package Foo::Trait::Attribute; use Moose::Role; } { package Foo::Role::Base; use Moose::Role; } { package Foo::Exporter; use Moose::Exporter; Moose::Exporter->setup_import_methods( class_metaroles => { class => ['Foo::Trait::Class'], attribute => ['Foo::Trait::Attribute'], }, role_metaroles => { role => ['Foo::Trait::Class'] }, base_class_roles => ['Foo::Role::Base'], ); } { package Foo; use Moose; Foo::Exporter->import; has foo => (is => 'ro'); ::does_ok(Foo->meta, 'Foo::Trait::Class'); ::does_ok(Foo->meta->get_attribute('foo'), 'Foo::Trait::Attribute'); ::does_ok('Foo', 'Foo::Role::Base'); } { package Foo::Exporter::WithMoose; use Moose (); use Moose::Exporter; my ( $import, $unimport, $init_meta ) = Moose::Exporter->build_import_methods( also => 'Moose', class_metaroles => { class => ['Foo::Trait::Class'], attribute => ['Foo::Trait::Attribute'], }, base_class_roles => ['Foo::Role::Base'], install => [qw(import unimport)], ); sub init_meta { my $package = shift; my %options = @_; ::pass('custom init_meta was called'); Moose->init_meta(%options); return $package->$init_meta(%options); } } { package Foo2; Foo::Exporter::WithMoose->import; has(foo => (is => 'ro')); ::isa_ok('Foo2', 'Moose::Object'); ::isa_ok(Foo2->meta, 'Moose::Meta::Class'); ::does_ok(Foo2->meta, 'Foo::Trait::Class'); ::does_ok(Foo2->meta->get_attribute('foo'), 'Foo::Trait::Attribute'); ::does_ok('Foo2', 'Foo::Role::Base'); } { package Foo::Role; use Moose::Role; Foo::Exporter->import; ::does_ok(Foo::Role->meta, 'Foo::Trait::Class'); } { package Foo::Exporter::WithMooseRole; use Moose::Role (); use Moose::Exporter; my ( $import, $unimport, $init_meta ) = Moose::Exporter->build_import_methods( also => 'Moose::Role', role_metaroles => { role => ['Foo::Trait::Class'], attribute => ['Foo::Trait::Attribute'], }, install => [qw(import unimport)], ); sub init_meta { my $package = shift; my %options = @_; ::pass('custom init_meta was called'); Moose::Role->init_meta(%options); return $package->$init_meta(%options); } } { package Foo2::Role; Foo::Exporter::WithMooseRole->import; ::isa_ok(Foo2::Role->meta, 'Moose::Meta::Role'); ::does_ok(Foo2::Role->meta, 'Foo::Trait::Class'); } done_testing; moose_exporter.t100644000767000024 4004012200352344 20360 0ustar00etherstaff000000000000Moose-2.1005/t/metaclasses#!/usr/bin/perl use strict; use warnings; use Test::More; use Test::Fatal; use Test::Moose; use Test::Requires { 'Test::Output' => '0.01', # skip all if not installed }; { package HasOwnImmutable; use Moose; no Moose; ::stderr_is( sub { eval q[sub make_immutable { return 'foo' }] }, '', 'no warning when defining our own make_immutable sub' ); } { is( HasOwnImmutable->make_immutable(), 'foo', 'HasOwnImmutable->make_immutable does not get overwritten' ); } { package MooseX::Empty; use Moose (); Moose::Exporter->setup_import_methods( also => 'Moose' ); } { package WantsMoose; MooseX::Empty->import(); sub foo { 1 } ::can_ok( 'WantsMoose', 'has' ); ::can_ok( 'WantsMoose', 'with' ); ::can_ok( 'WantsMoose', 'foo' ); MooseX::Empty->unimport(); } { # Note: it's important that these methods be out of scope _now_, # after unimport was called. We tried a # namespace::clean(0.08)-based solution, but had to abandon it # because it cleans the namespace _later_ (when the file scope # ends). ok( ! WantsMoose->can('has'), 'WantsMoose::has() has been cleaned' ); ok( ! WantsMoose->can('with'), 'WantsMoose::with() has been cleaned' ); can_ok( 'WantsMoose', 'foo' ); # This makes sure that Moose->init_meta() happens properly isa_ok( WantsMoose->meta(), 'Moose::Meta::Class' ); isa_ok( WantsMoose->new(), 'Moose::Object' ); } { package MooseX::Sugar; use Moose (); sub wrapped1 { my $meta = shift; return $meta->name . ' called wrapped1'; } Moose::Exporter->setup_import_methods( with_meta => ['wrapped1'], also => 'Moose', ); } { package WantsSugar; MooseX::Sugar->import(); sub foo { 1 } ::can_ok( 'WantsSugar', 'has' ); ::can_ok( 'WantsSugar', 'with' ); ::can_ok( 'WantsSugar', 'wrapped1' ); ::can_ok( 'WantsSugar', 'foo' ); ::is( wrapped1(), 'WantsSugar called wrapped1', 'wrapped1 identifies the caller correctly' ); MooseX::Sugar->unimport(); } { ok( ! WantsSugar->can('has'), 'WantsSugar::has() has been cleaned' ); ok( ! WantsSugar->can('with'), 'WantsSugar::with() has been cleaned' ); ok( ! WantsSugar->can('wrapped1'), 'WantsSugar::wrapped1() has been cleaned' ); can_ok( 'WantsSugar', 'foo' ); } { package MooseX::MoreSugar; use Moose (); sub wrapped2 { my $caller = shift->name; return $caller . ' called wrapped2'; } sub as_is1 { return 'as_is1'; } Moose::Exporter->setup_import_methods( with_meta => ['wrapped2'], as_is => ['as_is1'], also => 'MooseX::Sugar', ); } { package WantsMoreSugar; MooseX::MoreSugar->import(); sub foo { 1 } ::can_ok( 'WantsMoreSugar', 'has' ); ::can_ok( 'WantsMoreSugar', 'with' ); ::can_ok( 'WantsMoreSugar', 'wrapped1' ); ::can_ok( 'WantsMoreSugar', 'wrapped2' ); ::can_ok( 'WantsMoreSugar', 'as_is1' ); ::can_ok( 'WantsMoreSugar', 'foo' ); ::is( wrapped1(), 'WantsMoreSugar called wrapped1', 'wrapped1 identifies the caller correctly' ); ::is( wrapped2(), 'WantsMoreSugar called wrapped2', 'wrapped2 identifies the caller correctly' ); ::is( as_is1(), 'as_is1', 'as_is1 works as expected' ); MooseX::MoreSugar->unimport(); } { ok( ! WantsMoreSugar->can('has'), 'WantsMoreSugar::has() has been cleaned' ); ok( ! WantsMoreSugar->can('with'), 'WantsMoreSugar::with() has been cleaned' ); ok( ! WantsMoreSugar->can('wrapped1'), 'WantsMoreSugar::wrapped1() has been cleaned' ); ok( ! WantsMoreSugar->can('wrapped2'), 'WantsMoreSugar::wrapped2() has been cleaned' ); ok( ! WantsMoreSugar->can('as_is1'), 'WantsMoreSugar::as_is1() has been cleaned' ); can_ok( 'WantsMoreSugar', 'foo' ); } { package My::Metaclass; use Moose; BEGIN { extends 'Moose::Meta::Class' } package My::Object; use Moose; BEGIN { extends 'Moose::Object' } package HasInitMeta; use Moose (); sub init_meta { shift; return Moose->init_meta( @_, metaclass => 'My::Metaclass', base_class => 'My::Object', ); } Moose::Exporter->setup_import_methods( also => 'Moose' ); } { package NewMeta; HasInitMeta->import(); } { isa_ok( NewMeta->meta(), 'My::Metaclass' ); isa_ok( NewMeta->new(), 'My::Object' ); } { package MooseX::CircularAlso; use Moose (); ::like( ::exception{ Moose::Exporter->setup_import_methods( also => [ 'Moose', 'MooseX::CircularAlso' ], ); }, qr/\QCircular reference in 'also' parameter to Moose::Exporter between MooseX::CircularAlso and MooseX::CircularAlso/, 'a circular reference in also dies with an error' ); } { package MooseX::NoAlso; use Moose (); ::like( ::exception{ Moose::Exporter->setup_import_methods( also => ['NoSuchThing'], ); }, qr/\QPackage in also (NoSuchThing) does not seem to use Moose::Exporter (is it loaded?) at /, 'a package which does not use Moose::Exporter in also dies with an error' ); } { package MooseX::NotExporter; use Moose (); ::like( ::exception{ Moose::Exporter->setup_import_methods( also => ['Moose::Meta::Method'], ); }, qr/\QPackage in also (Moose::Meta::Method) does not seem to use Moose::Exporter at /, 'a package which does not use Moose::Exporter in also dies with an error' ); } { package MooseX::OverridingSugar; use Moose (); sub has { my $caller = shift->name; return $caller . ' called has'; } Moose::Exporter->setup_import_methods( with_meta => ['has'], also => 'Moose', ); } { package WantsOverridingSugar; MooseX::OverridingSugar->import(); ::can_ok( 'WantsOverridingSugar', 'has' ); ::can_ok( 'WantsOverridingSugar', 'with' ); ::is( has('foo'), 'WantsOverridingSugar called has', 'has from MooseX::OverridingSugar is called, not has from Moose' ); MooseX::OverridingSugar->unimport(); } { ok( ! WantsOverridingSugar->can('has'), 'WantsSugar::has() has been cleaned' ); ok( ! WantsOverridingSugar->can('with'), 'WantsSugar::with() has been cleaned' ); } { package MooseX::OverridingSugar::PassThru; sub with { my $caller = shift->name; return $caller . ' called with'; } Moose::Exporter->setup_import_methods( with_meta => ['with'], also => 'MooseX::OverridingSugar', ); } { package WantsOverridingSugar::PassThru; MooseX::OverridingSugar::PassThru->import(); ::can_ok( 'WantsOverridingSugar::PassThru', 'has' ); ::can_ok( 'WantsOverridingSugar::PassThru', 'with' ); ::is( has('foo'), 'WantsOverridingSugar::PassThru called has', 'has from MooseX::OverridingSugar is called, not has from Moose' ); ::is( with('foo'), 'WantsOverridingSugar::PassThru called with', 'with from MooseX::OverridingSugar::PassThru is called, not has from Moose' ); MooseX::OverridingSugar::PassThru->unimport(); } { ok( ! WantsOverridingSugar::PassThru->can('has'), 'WantsOverridingSugar::PassThru::has() has been cleaned' ); ok( ! WantsOverridingSugar::PassThru->can('with'), 'WantsOverridingSugar::PassThru::with() has been cleaned' ); } { package NonExistentExport; use Moose (); ::stderr_like { Moose::Exporter->setup_import_methods( also => ['Moose'], with_meta => ['does_not_exist'], ); } qr/^Trying to export undefined sub NonExistentExport::does_not_exist/, "warns when a non-existent method is requested to be exported"; } { package WantsNonExistentExport; NonExistentExport->import; ::ok(!__PACKAGE__->can('does_not_exist'), "undefined subs do not get exported"); } { package AllOptions; use Moose (); use Moose::Deprecated -api_version => '0.88'; use Moose::Exporter; Moose::Exporter->setup_import_methods( also => ['Moose'], with_meta => [ 'with_meta1', 'with_meta2' ], with_caller => [ 'with_caller1', 'with_caller2' ], as_is => ['as_is1'], ); sub with_caller1 { return @_; } sub with_caller2 (&) { return @_; } sub as_is1 {2} sub with_meta1 { return @_; } sub with_meta2 (&) { return @_; } } { package UseAllOptions; AllOptions->import(); } { can_ok( 'UseAllOptions', $_ ) for qw( with_meta1 with_meta2 with_caller1 with_caller2 as_is1 ); { my ( $caller, $arg1 ) = UseAllOptions::with_caller1(42); is( $caller, 'UseAllOptions', 'with_caller wrapped sub gets the right caller' ); is( $arg1, 42, 'with_caller wrapped sub returns argument it was passed' ); } { my ( $meta, $arg1 ) = UseAllOptions::with_meta1(42); isa_ok( $meta, 'Moose::Meta::Class', 'with_meta first argument' ); is( $arg1, 42, 'with_meta1 returns argument it was passed' ); } is( prototype( UseAllOptions->can('with_caller2') ), prototype( AllOptions->can('with_caller2') ), 'using correct prototype on with_meta function' ); is( prototype( UseAllOptions->can('with_meta2') ), prototype( AllOptions->can('with_meta2') ), 'using correct prototype on with_meta function' ); } { package UseAllOptions; AllOptions->unimport(); } { ok( ! UseAllOptions->can($_), "UseAllOptions::$_ has been unimported" ) for qw( with_meta1 with_meta2 with_caller1 with_caller2 as_is1 ); } { package InitMetaError; use Moose::Exporter; use Moose (); Moose::Exporter->setup_import_methods(also => ['Moose']); sub init_meta { my $package = shift; my %options = @_; Moose->init_meta(%options, metaclass => 'Not::Loaded'); } } { package InitMetaError::Role; use Moose::Exporter; use Moose::Role (); Moose::Exporter->setup_import_methods(also => ['Moose::Role']); sub init_meta { my $package = shift; my %options = @_; Moose::Role->init_meta(%options, metaclass => 'Not::Loaded'); } } { package WantsInvalidMetaclass; ::like( ::exception { InitMetaError->import }, qr/The Metaclass Not::Loaded must be loaded\. \(Perhaps you forgot to 'use Not::Loaded'\?\)/, "error when wanting a nonexistent metaclass" ); } { package WantsInvalidMetaclass::Role; ::like( ::exception { InitMetaError::Role->import }, qr/The Metaclass Not::Loaded must be loaded\. \(Perhaps you forgot to 'use Not::Loaded'\?\)/, "error when wanting a nonexistent metaclass" ); } { my @init_metas_called; BEGIN { package MultiLevelExporter1; use Moose::Exporter; sub foo { 1 } sub bar { 1 } sub baz { 1 } sub quux { 1 } Moose::Exporter->setup_import_methods( with_meta => [qw(foo bar baz quux)], ); sub init_meta { push @init_metas_called, 1; } $INC{'MultiLevelExporter1.pm'} = __FILE__; } BEGIN { package MultiLevelExporter2; use Moose::Exporter; sub bar { 2 } sub baz { 2 } sub quux { 2 } Moose::Exporter->setup_import_methods( also => ['MultiLevelExporter1'], with_meta => [qw(bar baz quux)], ); sub init_meta { push @init_metas_called, 2; } $INC{'MultiLevelExporter2.pm'} = __FILE__; } BEGIN { package MultiLevelExporter3; use Moose::Exporter; sub baz { 3 } sub quux { 3 } Moose::Exporter->setup_import_methods( also => ['MultiLevelExporter2'], with_meta => [qw(baz quux)], ); sub init_meta { push @init_metas_called, 3; } $INC{'MultiLevelExporter3.pm'} = __FILE__; } BEGIN { package MultiLevelExporter4; use Moose::Exporter; sub quux { 4 } Moose::Exporter->setup_import_methods( also => ['MultiLevelExporter3'], with_meta => [qw(quux)], ); sub init_meta { push @init_metas_called, 4; } $INC{'MultiLevelExporter4.pm'} = __FILE__; } BEGIN { @init_metas_called = () } { package UsesMulti1; use Moose; use MultiLevelExporter1; ::is(foo(), 1); ::is(bar(), 1); ::is(baz(), 1); ::is(quux(), 1); } use Data::Dumper; BEGIN { is_deeply(\@init_metas_called, [ 1 ]) || diag(Dumper(\@init_metas_called)) } BEGIN { @init_metas_called = () } { package UsesMulti2; use Moose; use MultiLevelExporter2; ::is(foo(), 1); ::is(bar(), 2); ::is(baz(), 2); ::is(quux(), 2); } BEGIN { is_deeply(\@init_metas_called, [ 2, 1 ]) || diag(Dumper(\@init_metas_called)) } BEGIN { @init_metas_called = () } { package UsesMulti3; use Moose; use MultiLevelExporter3; ::is(foo(), 1); ::is(bar(), 2); ::is(baz(), 3); ::is(quux(), 3); } BEGIN { is_deeply(\@init_metas_called, [ 3, 2, 1 ]) || diag(Dumper(\@init_metas_called)) } BEGIN { @init_metas_called = () } { package UsesMulti4; use Moose; use MultiLevelExporter4; ::is(foo(), 1); ::is(bar(), 2); ::is(baz(), 3); ::is(quux(), 4); } BEGIN { is_deeply(\@init_metas_called, [ 4, 3, 2, 1 ]) || diag(Dumper(\@init_metas_called)) } } # Using "also => [ 'MooseX::UsesAlsoMoose', 'MooseX::SomethingElse' ]" should # continue to work. The init_meta order needs to be MooseX::CurrentExporter, # MooseX::UsesAlsoMoose, Moose, MooseX::SomethingElse. This is a pretty ugly # and messed up use case, but necessary until we come up with a better way to # do it. { my @init_metas_called; BEGIN { package AlsoTest::Role1; use Moose::Role; $INC{'AlsoTest/Role1.pm'} = __FILE__; } BEGIN { package AlsoTest1; use Moose::Exporter; Moose::Exporter->setup_import_methods( also => [ 'Moose' ], ); sub init_meta { shift; my %opts = @_; ::ok(!Class::MOP::class_of($opts{for_class})); push @init_metas_called, 1; } $INC{'AlsoTest1.pm'} = __FILE__; } BEGIN { package AlsoTest2; use Moose::Exporter; use Moose::Util::MetaRole (); Moose::Exporter->setup_import_methods; sub init_meta { shift; my %opts = @_; ::ok(Class::MOP::class_of($opts{for_class})); Moose::Util::MetaRole::apply_metaroles( for => $opts{for_class}, class_metaroles => { class => ['AlsoTest::Role1'], }, ); push @init_metas_called, 2; } $INC{'AlsoTest2.pm'} = __FILE__; } BEGIN { package AlsoTest3; use Moose::Exporter; Moose::Exporter->setup_import_methods( also => [ 'AlsoTest1', 'AlsoTest2' ], ); sub init_meta { shift; my %opts = @_; ::ok(!Class::MOP::class_of($opts{for_class})); push @init_metas_called, 3; } $INC{'AlsoTest3.pm'} = __FILE__; } BEGIN { @init_metas_called = () } { package UsesAlsoTest3; use AlsoTest3; } use Data::Dumper; BEGIN { is_deeply(\@init_metas_called, [ 3, 1, 2 ]) || diag(Dumper(\@init_metas_called)); isa_ok(Class::MOP::class_of('UsesAlsoTest3'), 'Moose::Meta::Class'); does_ok(Class::MOP::class_of('UsesAlsoTest3'), 'AlsoTest::Role1'); } } done_testing; moose_for_meta.t100644000767000024 400712200352344 20267 0ustar00etherstaff000000000000Moose-2.1005/t/metaclasses#!/usr/bin/perl use strict; use warnings; use Test::More; =pod This test demonstrates the ability to extend Moose meta-level classes using Moose itself. =cut { package My::Meta::Class; use Moose; extends 'Moose::Meta::Class'; around 'create_anon_class' => sub { my $next = shift; my ($self, %options) = @_; $options{superclasses} = [ 'Moose::Object' ] unless exists $options{superclasses}; $next->($self, %options); }; } my $anon = My::Meta::Class->create_anon_class(); isa_ok($anon, 'My::Meta::Class'); isa_ok($anon, 'Moose::Meta::Class'); isa_ok($anon, 'Class::MOP::Class'); is_deeply( [ $anon->superclasses ], [ 'Moose::Object' ], '... got the default superclasses'); { package My::Meta::Attribute::DefaultReadOnly; use Moose; extends 'Moose::Meta::Attribute'; around 'new' => sub { my $next = shift; my ($self, $name, %options) = @_; $options{is} = 'ro' unless exists $options{is}; $next->($self, $name, %options); }; } { my $attr = My::Meta::Attribute::DefaultReadOnly->new('foo'); isa_ok($attr, 'My::Meta::Attribute::DefaultReadOnly'); isa_ok($attr, 'Moose::Meta::Attribute'); isa_ok($attr, 'Class::MOP::Attribute'); ok($attr->has_reader, '... the attribute has a reader (as expected)'); ok(!$attr->has_writer, '... the attribute does not have a writer (as expected)'); ok(!$attr->has_accessor, '... the attribute does not have an accessor (as expected)'); } { my $attr = My::Meta::Attribute::DefaultReadOnly->new('foo', (is => 'rw')); isa_ok($attr, 'My::Meta::Attribute::DefaultReadOnly'); isa_ok($attr, 'Moose::Meta::Attribute'); isa_ok($attr, 'Class::MOP::Attribute'); ok(!$attr->has_reader, '... the attribute does not have a reader (as expected)'); ok(!$attr->has_writer, '... the attribute does not have a writer (as expected)'); ok($attr->has_accessor, '... the attribute does have an accessor (as expected)'); } done_testing; method_mod_args.t100644000767000024 113112200352344 20272 0ustar00etherstaff000000000000Moose-2.1005/t/moose_utiluse strict; use warnings; use Test::More; use Test::Fatal; use Moose::Util qw( add_method_modifier ); my $COUNT = 0; { package Foo; use Moose; sub foo { } sub bar { } } is( exception { add_method_modifier('Foo', 'before', [ ['foo', 'bar'], sub { $COUNT++ } ]); }, undef, 'method modifier with an arrayref' ); isnt( exception { add_method_modifier('Foo', 'before', [ {'foo' => 'bar'}, sub { $COUNT++ } ]); }, undef, 'method modifier with a hashref' ); my $foo = Foo->new; $foo->foo; $foo->bar; is($COUNT, 2, "checking that the modifiers were installed."); done_testing; array_coerce.t100644000767000024 1072212200352344 20320 0ustar00etherstaff000000000000Moose-2.1005/t/native_traitsuse strict; use warnings; use Test::More; use Test::Fatal; { package Foo; use Moose; use Moose::Util::TypeConstraints; subtype 'UCArray', as 'ArrayRef[Str]', where { !grep {/[a-z]/} @{$_}; }; coerce 'UCArray', from 'ArrayRef[Str]', via { [ map { uc $_ } @{$_} ]; }; has array => ( traits => ['Array'], is => 'rw', isa => 'UCArray', coerce => 1, handles => { push_array => 'push', set_array => 'set', }, ); our @TriggerArgs; has lazy => ( traits => ['Array'], is => 'rw', isa => 'UCArray', coerce => 1, lazy => 1, default => sub { ['a'] }, handles => { push_lazy => 'push', set_lazy => 'set', }, trigger => sub { @TriggerArgs = @_ }, clearer => 'clear_lazy', ); } my $foo = Foo->new; { $foo->array( [qw( A B C )] ); $foo->push_array('d'); is_deeply( $foo->array, [qw( A B C D )], 'push coerces the array' ); $foo->set_array( 1 => 'x' ); is_deeply( $foo->array, [qw( A X C D )], 'set coerces the array' ); } { $foo->push_lazy('d'); is_deeply( $foo->lazy, [qw( A D )], 'push coerces the array - lazy' ); is_deeply( \@Foo::TriggerArgs, [ $foo, [qw( A D )], ['A'] ], 'trigger receives expected arguments' ); $foo->set_lazy( 2 => 'f' ); is_deeply( $foo->lazy, [qw( A D F )], 'set coerces the array - lazy' ); is_deeply( \@Foo::TriggerArgs, [ $foo, [qw( A D F )], [qw( A D )] ], 'trigger receives expected arguments' ); } { package Thing; use Moose; has thing => ( is => 'ro', isa => 'Int', ); } { package Bar; use Moose; use Moose::Util::TypeConstraints; class_type 'Thing'; coerce 'Thing' => from 'Int' => via { Thing->new( thing => $_ ) }; subtype 'ArrayRefOfThings' => as 'ArrayRef[Thing]'; coerce 'ArrayRefOfThings' => from 'ArrayRef[Int]' => via { [ map { Thing->new( thing => $_ ) } @{$_} ] }; coerce 'ArrayRefOfThings' => from 'Int' => via { [ Thing->new( thing => $_ ) ] }; has array => ( traits => ['Array'], is => 'rw', isa => 'ArrayRefOfThings', coerce => 1, handles => { push_array => 'push', unshift_array => 'unshift', set_array => 'set', insert_array => 'insert', }, ); } { my $bar = Bar->new( array => [ 1, 2, 3 ] ); $bar->push_array( 4, 5 ); is_deeply( [ map { $_->thing } @{ $bar->array } ], [ 1, 2, 3, 4, 5 ], 'push coerces new members' ); $bar->unshift_array( -1, 0 ); is_deeply( [ map { $_->thing } @{ $bar->array } ], [ -1, 0, 1, 2, 3, 4, 5 ], 'unshift coerces new members' ); $bar->set_array( 3 => 9 ); is_deeply( [ map { $_->thing } @{ $bar->array } ], [ -1, 0, 1, 9, 3, 4, 5 ], 'set coerces new members' ); $bar->insert_array( 3 => 42 ); is_deeply( [ map { $_->thing } @{ $bar->array } ], [ -1, 0, 1, 42, 9, 3, 4, 5 ], 'insert coerces new members' ); } { package Baz; use Moose; use Moose::Util::TypeConstraints; subtype 'SmallArrayRef' => as 'ArrayRef' => where { @{$_} <= 2 }; coerce 'SmallArrayRef' => from 'ArrayRef' => via { [ @{$_}[ -2, -1 ] ] }; has array => ( traits => ['Array'], is => 'rw', isa => 'SmallArrayRef', coerce => 1, handles => { push_array => 'push', set_array => 'set', insert_array => 'insert', }, ); } { my $baz = Baz->new( array => [ 1, 2, 3 ] ); is_deeply( $baz->array, [ 2, 3 ], 'coercion truncates array ref in constructor' ); $baz->push_array(4); is_deeply( $baz->array, [ 3, 4 ], 'coercion truncates array ref on push' ); $baz->insert_array( 1 => 5 ); is_deeply( $baz->array, [ 5, 4 ], 'coercion truncates array ref on insert' ); $baz->push_array( 7, 8, 9 ); is_deeply( $baz->array, [ 8, 9 ], 'coercion truncates array ref on push' ); } done_testing; hash_trigger.t100644000767000024 171712200352344 20314 0ustar00etherstaff000000000000Moose-2.1005/t/native_traitsuse strict; use warnings; use Test::More; { package Foo; use Moose; our @TriggerArgs; has hash => ( traits => ['Hash'], is => 'rw', isa => 'HashRef', handles => { delete_key => 'delete', set_key => 'set', }, clearer => 'clear_key', trigger => sub { @TriggerArgs = @_ }, ); } my $foo = Foo->new; { $foo->hash( { x => 1, y => 2 } ); is_deeply( \@Foo::TriggerArgs, [ $foo, { x => 1, y => 2 } ], 'trigger was called for normal writer' ); $foo->set_key( z => 5 ); is_deeply( \@Foo::TriggerArgs, [ $foo, { x => 1, y => 2, z => 5 }, { x => 1, y => 2 } ], 'trigger was called on set' ); $foo->delete_key('y'); is_deeply( \@Foo::TriggerArgs, [ $foo, { x => 1, z => 5 }, { x => 1, y => 2, z => 5 } ], 'trigger was called on delete' ); } done_testing; trait_number.t100644000767000024 1036412200352344 20357 0ustar00etherstaff000000000000Moose-2.1005/t/native_traits#!/usr/bin/perl use strict; use warnings; use lib 't/lib'; use Moose (); use Moose::Util::TypeConstraints; use NoInlineAttribute; use Test::Fatal; use Test::More; use Test::Moose; { my %handles = ( abs => 'abs', add => 'add', inc => [ add => 1 ], div => 'div', cut_in_half => [ div => 2 ], mod => 'mod', odd => [ mod => 2 ], mul => 'mul', set => 'set', sub => 'sub', dec => [ sub => 1 ], ); my $name = 'Foo1'; sub build_class { my %attr = @_; my $class = Moose::Meta::Class->create( $name++, superclasses => ['Moose::Object'], ); my @traits = 'Number'; push @traits, 'NoInlineAttribute' if delete $attr{no_inline}; $class->add_attribute( integer => ( traits => \@traits, is => 'ro', isa => 'Int', default => 5, handles => \%handles, clearer => '_clear_integer', %attr, ), ); return ( $class->name, \%handles ); } } { run_tests(build_class); run_tests( build_class( lazy => 1 ) ); run_tests( build_class( trigger => sub { } ) ); run_tests( build_class( no_inline => 1 ) ); # Will force the inlining code to check the entire hashref when it is modified. subtype 'MyInt', as 'Int', where { 1 }; run_tests( build_class( isa => 'MyInt' ) ); coerce 'MyInt', from 'Int', via { $_ }; run_tests( build_class( isa => 'MyInt', coerce => 1 ) ); } sub run_tests { my ( $class, $handles ) = @_; can_ok( $class, $_ ) for sort keys %{$handles}; with_immutable { my $obj = $class->new; is( $obj->integer, 5, 'Default to five' ); is( $obj->add(10), 15, 'add returns new value' ); is( $obj->integer, 15, 'Add ten for fithteen' ); like( exception { $obj->add( 10, 2 ) }, qr/Cannot call add with more than 1 argument/, 'add throws an error when 2 arguments are passed' ); is( $obj->sub(3), 12, 'sub returns new value' ); is( $obj->integer, 12, 'Subtract three for 12' ); like( exception { $obj->sub( 10, 2 ) }, qr/Cannot call sub with more than 1 argument/, 'sub throws an error when 2 arguments are passed' ); is( $obj->set(10), 10, 'set returns new value' ); is( $obj->integer, 10, 'Set to ten' ); like( exception { $obj->set( 10, 2 ) }, qr/Cannot call set with more than 1 argument/, 'set throws an error when 2 arguments are passed' ); is( $obj->div(2), 5, 'div returns new value' ); is( $obj->integer, 5, 'divide by 2' ); like( exception { $obj->div( 10, 2 ) }, qr/Cannot call div with more than 1 argument/, 'div throws an error when 2 arguments are passed' ); is( $obj->mul(2), 10, 'mul returns new value' ); is( $obj->integer, 10, 'multiplied by 2' ); like( exception { $obj->mul( 10, 2 ) }, qr/Cannot call mul with more than 1 argument/, 'mul throws an error when 2 arguments are passed' ); is( $obj->mod(2), 0, 'mod returns new value' ); is( $obj->integer, 0, 'Mod by 2' ); like( exception { $obj->mod( 10, 2 ) }, qr/Cannot call mod with more than 1 argument/, 'mod throws an error when 2 arguments are passed' ); $obj->set(7); $obj->mod(5); is( $obj->integer, 2, 'Mod by 5' ); $obj->set(-1); is( $obj->abs, 1, 'abs returns new value' ); like( exception { $obj->abs(10) }, qr/Cannot call abs with any arguments/, 'abs throws an error when an argument is passed' ); is( $obj->integer, 1, 'abs 1' ); $obj->set(12); $obj->inc; is( $obj->integer, 13, 'inc 12' ); $obj->dec; is( $obj->integer, 12, 'dec 13' ); if ( $class->meta->get_attribute('integer')->is_lazy ) { my $obj = $class->new; $obj->add(2); is( $obj->integer, 7, 'add with lazy default' ); $obj->_clear_integer; $obj->mod(2); is( $obj->integer, 1, 'mod with lazy default' ); } } $class; } done_testing; trait_string.t100644000767000024 2335612200352344 20402 0ustar00etherstaff000000000000Moose-2.1005/t/native_traits#!/usr/bin/perl use strict; use warnings; use lib 't/lib'; use Moose (); use Moose::Util::TypeConstraints; use NoInlineAttribute; use Test::More; use Test::Fatal; use Test::Moose; { my %handles = ( inc => 'inc', append => 'append', append_curried => [ append => '!' ], prepend => 'prepend', prepend_curried => [ prepend => '-' ], replace => 'replace', replace_curried => [ replace => qr/(.)$/, sub { uc $1 } ], chop => 'chop', chomp => 'chomp', clear => 'clear', match => 'match', match_curried => [ match => qr/\D/ ], length => 'length', substr => 'substr', substr_curried_1 => [ substr => (1) ], substr_curried_2 => [ substr => ( 1, 3 ) ], substr_curried_3 => [ substr => ( 1, 3, 'ong' ) ], ); my $name = 'Foo1'; sub build_class { my %attr = @_; my $class = Moose::Meta::Class->create( $name++, superclasses => ['Moose::Object'], ); my @traits = 'String'; push @traits, 'NoInlineAttribute' if delete $attr{no_inline}; $class->add_attribute( _string => ( traits => \@traits, is => 'rw', isa => 'Str', default => q{}, handles => \%handles, clearer => '_clear_string', %attr, ), ); return ( $class->name, \%handles ); } } { run_tests(build_class); run_tests( build_class( lazy => 1, default => q{} ) ); run_tests( build_class( trigger => sub { } ) ); run_tests( build_class( no_inline => 1 ) ); # Will force the inlining code to check the entire hashref when it is modified. subtype 'MyStr', as 'Str', where { 1 }; run_tests( build_class( isa => 'MyStr' ) ); coerce 'MyStr', from 'Str', via { $_ }; run_tests( build_class( isa => 'MyStr', coerce => 1 ) ); } sub run_tests { my ( $class, $handles ) = @_; can_ok( $class, $_ ) for sort keys %{$handles}; with_immutable { my $obj = $class->new(); is( $obj->length, 0, 'length returns zero' ); $obj->_string('a'); is( $obj->length, 1, 'length returns 1 for new string' ); like( exception { $obj->length(42) }, qr/Cannot call length with any arguments/, 'length throws an error when an argument is passed' ); is( $obj->inc, 'b', 'inc returns new value' ); is( $obj->_string, 'b', 'a becomes b after inc' ); like( exception { $obj->inc(42) }, qr/Cannot call inc with any arguments/, 'inc throws an error when an argument is passed' ); is( $obj->append('foo'), 'bfoo', 'append returns new value' ); is( $obj->_string, 'bfoo', 'appended to the string' ); like( exception { $obj->append( 'foo', 2 ) }, qr/Cannot call append with more than 1 argument/, 'append throws an error when two arguments are passed' ); $obj->append_curried; is( $obj->_string, 'bfoo!', 'append_curried appended to the string' ); like( exception { $obj->append_curried('foo') }, qr/Cannot call append with more than 1 argument/, 'append_curried throws an error when two arguments are passed' ); $obj->_string("has nl$/"); is( $obj->chomp, 1, 'chomp returns number of characters removed' ); is( $obj->_string, 'has nl', 'chomped string' ); is( $obj->chomp, 0, 'chomp returns number of characters removed' ); is( $obj->_string, 'has nl', 'chomp is a no-op when string has no line ending' ); like( exception { $obj->chomp(42) }, qr/Cannot call chomp with any arguments/, 'chomp throws an error when an argument is passed' ); is( $obj->chop, 'l', 'chop returns character removed' ); is( $obj->_string, 'has n', 'chopped string' ); like( exception { $obj->chop(42) }, qr/Cannot call chop with any arguments/, 'chop throws an error when an argument is passed' ); $obj->_string('x'); is( $obj->prepend('bar'), 'barx', 'prepend returns new value' ); is( $obj->_string, 'barx', 'prepended to string' ); $obj->prepend_curried; is( $obj->_string, '-barx', 'prepend_curried prepended to string' ); is( $obj->replace( qr/([ao])/, sub { uc($1) } ), '-bArx', 'replace returns new value' ); is( $obj->_string, '-bArx', 'substitution using coderef for replacement' ); $obj->replace( qr/A/, 'X' ); is( $obj->_string, '-bXrx', 'substitution using string as replacement' ); $obj->_string('foo'); $obj->replace( qr/oo/, q{} ); is( $obj->_string, 'f', 'replace accepts an empty string as second argument' ); $obj->replace( q{}, 'a' ); is( $obj->_string, 'af', 'replace accepts an empty string as first argument' ); like( exception { $obj->replace( {}, 'x' ) }, qr/The first argument passed to replace must be a string or regexp reference/, 'replace throws an error when the first argument is not a string or regexp' ); like( exception { $obj->replace( qr/x/, {} ) }, qr/The second argument passed to replace must be a string or code reference/, 'replace throws an error when the first argument is not a string or regexp' ); $obj->_string('Moosex'); $obj->replace_curried; is( $obj->_string, 'MooseX', 'capitalize last' ); $obj->_string('abcdef'); is_deeply( [ $obj->match(qr/([az]).*([fy])/) ], [ 'a', 'f' ], 'match -barx against /[aq]/ returns matches' ); is_deeply( [ $obj->match(qr/([az]).*([fy])/) ], [ 'a', 'f' ], 'match -barx against /[aq]/ returns matches' ); ok( scalar $obj->match('b'), 'match with string as argument returns true' ); ok( scalar $obj->match(q{}), 'match with empty string as argument returns true' ); like( exception { $obj->match }, qr/Cannot call match without at least 1 argument/, 'match throws an error when no arguments are passed' ); like( exception { $obj->match( {} ) }, qr/The argument passed to match must be a string or regexp reference/, 'match throws an error when an invalid argument is passed' ); $obj->_string('1234'); ok( !$obj->match_curried, 'match_curried returns false' ); $obj->_string('one two three four'); ok( $obj->match_curried, 'match curried returns true' ); $obj->clear; is( $obj->_string, q{}, 'clear' ); like( exception { $obj->clear(42) }, qr/Cannot call clear with any arguments/, 'clear throws an error when an argument is passed' ); $obj->_string('some long string'); is( $obj->substr(1), 'ome long string', 'substr as getter with one argument' ); $obj->_string('some long string'); is( $obj->substr( 1, 3 ), 'ome', 'substr as getter with two arguments' ); is( $obj->substr( 1, 3, 'ong' ), 'ome', 'substr as setter returns replaced string' ); is( $obj->_string, 'song long string', 'substr as setter with three arguments' ); $obj->substr( 1, 3, '' ); is( $obj->_string, 's long string', 'substr as setter with three arguments, replacment is empty string' ); like( exception { $obj->substr }, qr/Cannot call substr without at least 1 argument/, 'substr throws an error when no argumemts are passed' ); like( exception { $obj->substr( 1, 2, 3, 4 ) }, qr/Cannot call substr with more than 3 arguments/, 'substr throws an error when four argumemts are passed' ); like( exception { $obj->substr( {} ) }, qr/The first argument passed to substr must be an integer/, 'substr throws an error when first argument is not an integer' ); like( exception { $obj->substr( 1, {} ) }, qr/The second argument passed to substr must be an integer/, 'substr throws an error when second argument is not an integer' ); like( exception { $obj->substr( 1, 2, {} ) }, qr/The third argument passed to substr must be a string/, 'substr throws an error when third argument is not a string' ); $obj->_string('some long string'); is( $obj->substr_curried_1, 'ome long string', 'substr_curried_1 returns expected value' ); is( $obj->substr_curried_1(3), 'ome', 'substr_curried_1 with one argument returns expected value' ); $obj->substr_curried_1( 3, 'ong' ); is( $obj->_string, 'song long string', 'substr_curried_1 as setter with two arguments' ); $obj->_string('some long string'); is( $obj->substr_curried_2, 'ome', 'substr_curried_2 returns expected value' ); $obj->substr_curried_2('ong'); is( $obj->_string, 'song long string', 'substr_curried_2 as setter with one arguments' ); $obj->_string('some long string'); $obj->substr_curried_3; is( $obj->_string, 'song long string', 'substr_curried_3 as setter' ); if ( $class->meta->get_attribute('_string')->is_lazy ) { my $obj = $class->new; $obj->append('foo'); is( $obj->_string, 'foo', 'append with lazy default' ); } } $class; } done_testing; create_role_subclass.t100644000767000024 105512200352344 20274 0ustar00etherstaff000000000000Moose-2.1005/t/roles#!/usr/bin/env perl use strict; use warnings; use Test::More; use Moose (); do { package My::Meta::Role; use Moose; extends 'Moose::Meta::Role'; has test_serial => ( is => 'ro', isa => 'Int', default => 1, ); no Moose; }; my $role = My::Meta::Role->create_anon_role; is($role->test_serial, 1, "default value for the serial attribute"); my $nine_role = My::Meta::Role->create_anon_role(test_serial => 9); is($nine_role->test_serial, 9, "parameter value for the serial attribute"); done_testing; extending_role_attrs.t100644000767000024 1031412200352344 20352 0ustar00etherstaff000000000000Moose-2.1005/t/roles#!/usr/bin/perl use strict; use warnings; use Test::More; use Test::Fatal; =pod This basically just makes sure that using +name on role attributes works right. =cut { package Foo::Role; use Moose::Role; has 'bar' => ( is => 'rw', isa => 'Int', default => sub { 10 }, ); package Foo; use Moose; with 'Foo::Role'; ::is( ::exception { has '+bar' => (default => sub { 100 }); }, undef, '... extended the attribute successfully' ); } my $foo = Foo->new; isa_ok($foo, 'Foo'); is($foo->bar, 100, '... got the extended attribute'); { package Bar::Role; use Moose::Role; has 'foo' => ( is => 'rw', isa => 'Str | Int', ); package Bar; use Moose; with 'Bar::Role'; ::is( ::exception { has '+foo' => ( isa => 'Int', ) }, undef, "... narrowed the role's type constraint successfully" ); } my $bar = Bar->new(foo => 42); isa_ok($bar, 'Bar'); is($bar->foo, 42, '... got the extended attribute'); $bar->foo(100); is($bar->foo, 100, "... can change the attribute's value to an Int"); like( exception { $bar->foo("baz") }, qr/^Attribute \(foo\) does not pass the type constraint because: Validation failed for 'Int' with value .*baz.* at / ); is($bar->foo, 100, "... still has the old Int value"); { package Baz::Role; use Moose::Role; has 'baz' => ( is => 'rw', isa => 'Value', ); package Baz; use Moose; with 'Baz::Role'; ::is( ::exception { has '+baz' => ( isa => 'Int | ClassName', ) }, undef, "... narrowed the role's type constraint successfully" ); } my $baz = Baz->new(baz => 99); isa_ok($baz, 'Baz'); is($baz->baz, 99, '... got the extended attribute'); $baz->baz('Foo'); is($baz->baz, 'Foo', "... can change the attribute's value to a ClassName"); like( exception { $baz->baz("zonk") }, qr/^Attribute \(baz\) does not pass the type constraint because: Validation failed for 'ClassName\|Int' with value .*zonk.* at / ); is_deeply($baz->baz, 'Foo', "... still has the old ClassName value"); { package Quux::Role; use Moose::Role; has 'quux' => ( is => 'rw', isa => 'Str | Int | Ref', ); package Quux; use Moose; use Moose::Util::TypeConstraints; with 'Quux::Role'; subtype 'Positive' => as 'Int' => where { $_ > 0 }; ::is( ::exception { has '+quux' => ( isa => 'Positive | ArrayRef', ) }, undef, "... narrowed the role's type constraint successfully" ); } my $quux = Quux->new(quux => 99); isa_ok($quux, 'Quux'); is($quux->quux, 99, '... got the extended attribute'); $quux->quux(100); is($quux->quux, 100, "... can change the attribute's value to an Int"); $quux->quux(["hi"]); is_deeply($quux->quux, ["hi"], "... can change the attribute's value to an ArrayRef"); like( exception { $quux->quux("quux") }, qr/^Attribute \(quux\) does not pass the type constraint because: Validation failed for 'ArrayRef\|Positive' with value .*quux.* at / ); is_deeply($quux->quux, ["hi"], "... still has the old ArrayRef value"); like( exception { $quux->quux({a => 1}) }, qr/^Attribute \(quux\) does not pass the type constraint because: Validation failed for 'ArrayRef\|Positive' with value .+ at / ); is_deeply($quux->quux, ["hi"], "... still has the old ArrayRef value"); { package Err::Role; use Moose::Role; for (1..3) { has "err$_" => ( isa => 'Str | Int', is => 'bare', ); } package Err; use Moose; with 'Err::Role'; ::is( ::exception { has '+err1' => (isa => 'Defined'); }, undef, "can get less specific in the subclass" ); ::is( ::exception { has '+err2' => (isa => 'Bool'); }, undef, "or change the type completely" ); ::is( ::exception { has '+err3' => (isa => 'Str | ArrayRef'); }, undef, "or add new types to the union" ); } { package Role::With::PlusAttr; use Moose::Role; with 'Foo::Role'; ::like( ::exception { has '+bar' => ( is => 'ro' ); }, qr/has '\+attr' is not supported in roles/, "Test has '+attr' in roles explodes" ); } done_testing; free_anonymous_roles.t100644000767000024 320012200352344 20340 0ustar00etherstaff000000000000Moose-2.1005/t/roles#!/usr/bin/env perl use strict; use warnings; use Test::More; use Moose (); use Scalar::Util 'weaken'; my $weak; my $name; do { my $anon_class; do { my $role = Moose::Meta::Role->create_anon_role( methods => { improperly_freed => sub { 1 }, }, ); weaken($weak = $role); $name = $role->name; $anon_class = Moose::Meta::Class->create_anon_class( roles => [ $role->name ], ); }; ok($weak, "we still have the role metaclass because the anonymous class that consumed it is still alive"); ok($name->can('improperly_freed'), "we have not blown away the role's symbol table"); }; ok(!$weak, "the role metaclass is freed after its last reference (from a consuming anonymous class) is freed"); ok(!$name->can('improperly_freed'), "we blew away the role's symbol table entries"); do { my $anon_class; do { my $role = Moose::Meta::Role->create_anon_role( methods => { improperly_freed => sub { 1 }, }, weaken => 0, ); weaken($weak = $role); $name = $role->name; $anon_class = Moose::Meta::Class->create_anon_class( roles => [ $role->name ], ); }; ok($weak, "we still have the role metaclass because the anonymous class that consumed it is still alive"); ok($name->can('improperly_freed'), "we have not blown away the role's symbol table"); }; ok($weak, "the role metaclass still exists because we told it not to weaken"); ok($name->can('improperly_freed'), "the symbol table still exists too"); done_testing; more_role_edge_cases.t100644000767000024 1511712200352344 20262 0ustar00etherstaff000000000000Moose-2.1005/t/roles#!/usr/bin/perl use strict; use warnings; use Test::More; use Test::Fatal; { # NOTE: # this tests that repeated role # composition will not cause # a conflict between two methods # which are actually the same anyway { package RootA; use Moose::Role; sub foo { "RootA::foo" } package SubAA; use Moose::Role; with "RootA"; sub bar { "SubAA::bar" } package SubAB; use Moose; ::is( ::exception { with "SubAA", "RootA"; }, undef, '... role was composed as expected' ); } ok( SubAB->does("SubAA"), "does SubAA"); ok( SubAB->does("RootA"), "does RootA"); isa_ok( my $i = SubAB->new, "SubAB" ); can_ok( $i, "bar" ); is( $i->bar, "SubAA::bar", "... got thr right bar rv" ); can_ok( $i, "foo" ); my $foo_rv; is( exception { $foo_rv = $i->foo; }, undef, '... called foo successfully' ); is($foo_rv, "RootA::foo", "... got the right foo rv"); } { # NOTE: # this edge cases shows the application of # an after modifier over a method which # was added during role composotion. # The way this will work is as follows: # role SubBA will consume RootB and # get a local copy of RootB::foo, it # will also store a deferred after modifier # to be applied to whatever class SubBA is # composed into. # When class SubBB comsumed role SubBA, the # RootB::foo method is added to SubBB, then # the deferred after modifier from SubBA is # applied to it. # It is important to note that the application # of the after modifier does not happen until # role SubBA is composed into SubAA. { package RootB; use Moose::Role; sub foo { "RootB::foo" } package SubBA; use Moose::Role; with "RootB"; has counter => ( isa => "Num", is => "rw", default => 0, ); after foo => sub { $_[0]->counter( $_[0]->counter + 1 ); }; package SubBB; use Moose; ::is( ::exception { with "SubBA"; }, undef, '... composed the role successfully' ); } ok( SubBB->does("SubBA"), "BB does SubBA" ); ok( SubBB->does("RootB"), "BB does RootB" ); isa_ok( my $i = SubBB->new, "SubBB" ); can_ok( $i, "foo" ); my $foo_rv; is( exception { $foo_rv = $i->foo }, undef, '... called foo successfully' ); is( $foo_rv, "RootB::foo", "foo rv" ); is( $i->counter, 1, "after hook called" ); is( exception { $i->foo }, undef, '... called foo successfully (again)' ); is( $i->counter, 2, "after hook called (again)" ); ok(SubBA->meta->has_method('foo'), '... this has the foo method'); #my $subba_foo_rv; #lives_ok { # $subba_foo_rv = SubBA::foo(); #} '... called the sub as a function correctly'; #is($subba_foo_rv, 'RootB::foo', '... the SubBA->foo is still the RootB version'); } { # NOTE: # this checks that an override method # does not try to trample over a locally # composed in method. In this case the # RootC::foo, which is composed into # SubCA cannot be trampled with an # override of 'foo' { package RootC; use Moose::Role; sub foo { "RootC::foo" } package SubCA; use Moose::Role; with "RootC"; ::isnt( ::exception { override foo => sub { "overridden" }; }, undef, '... cannot compose an override over a local method' ); } } # NOTE: # need to talk to Yuval about the motivation behind # this test, I am not sure we are testing anything # useful here (although more tests cant hurt) { use List::Util qw/shuffle/; { package Abstract; use Moose::Role; requires "method"; requires "other"; sub another { "abstract" } package ConcreteA; use Moose::Role; with "Abstract"; sub other { "concrete a" } package ConcreteB; use Moose::Role; with "Abstract"; sub method { "concrete b" } package ConcreteC; use Moose::Role; with "ConcreteA"; # NOTE: # this was originally override, but # that wont work (see above set of tests) # so I switched it to around. # However, this may not be testing the # same thing that was originally intended around other => sub { return ( (shift)->() . " + c" ); }; package SimpleClassWithSome; use Moose; eval { with ::shuffle qw/ConcreteA ConcreteB/ }; ::ok( !$@, "simple composition without abstract" ) || ::diag $@; package SimpleClassWithAll; use Moose; eval { with ::shuffle qw/ConcreteA ConcreteB Abstract/ }; ::ok( !$@, "simple composition with abstract" ) || ::diag $@; } foreach my $class (qw/SimpleClassWithSome SimpleClassWithAll/) { foreach my $role (qw/Abstract ConcreteA ConcreteB/) { ok( $class->does($role), "$class does $role"); } foreach my $method (qw/method other another/) { can_ok( $class, $method ); } is( eval { $class->another }, "abstract", "provided by abstract" ); is( eval { $class->other }, "concrete a", "provided by concrete a" ); is( eval { $class->method }, "concrete b", "provided by concrete b" ); } { package ClassWithSome; use Moose; eval { with ::shuffle qw/ConcreteC ConcreteB/ }; ::ok( !$@, "composition without abstract" ) || ::diag $@; package ClassWithAll; use Moose; eval { with ::shuffle qw/ConcreteC Abstract ConcreteB/ }; ::ok( !$@, "composition with abstract" ) || ::diag $@; package ClassWithEverything; use Moose; eval { with ::shuffle qw/ConcreteC Abstract ConcreteA ConcreteB/ }; # this should clash ::ok( !$@, "can compose ConcreteA and ConcreteC together" ); } foreach my $class (qw/ClassWithSome ClassWithAll ClassWithEverything/) { foreach my $role (qw/Abstract ConcreteA ConcreteB ConcreteC/) { ok( $class->does($role), "$class does $role"); } foreach my $method (qw/method other another/) { can_ok( $class, $method ); } is( eval { $class->another }, "abstract", "provided by abstract" ); is( eval { $class->other }, "concrete a + c", "provided by concrete c + a" ); is( eval { $class->method }, "concrete b", "provided by concrete b" ); } } done_testing; role_for_combination.t100644000767000024 166612200352344 20312 0ustar00etherstaff000000000000Moose-2.1005/t/roles#!/usr/bin/env perl use strict; use warnings; use Test::More; my $OPTS; do { package My::Singleton::Role; use Moose::Role; sub foo { 'My::Singleton::Role' } package My::Role::Metaclass; use Moose; BEGIN { extends 'Moose::Meta::Role' }; sub _role_for_combination { my ($self, $opts) = @_; $OPTS = $opts; return My::Singleton::Role->meta; } package My::Special::Role; use Moose::Role -metaclass => 'My::Role::Metaclass'; sub foo { 'My::Special::Role' } package My::Usual::Role; use Moose::Role; sub bar { 'My::Usual::Role' } package My::Class; use Moose; with ( 'My::Special::Role' => { number => 1 }, 'My::Usual::Role' => { number => 2 }, ); }; is(My::Class->foo, 'My::Singleton::Role', 'role_for_combination applied'); is(My::Class->bar, 'My::Usual::Role', 'collateral role'); is_deeply($OPTS, { number => 1 }); done_testing; debugger-duck_type.t100644000767000024 51112200352344 20204 0ustar00etherstaff000000000000Moose-2.1005/xt/author#!/usr/bin/perl use FindBin qw/ $Bin /; BEGIN { #line 1 #!/usr/bin/perl -d push @DB::typeahead, "c", "q"; # try to shut it up at least a little bit open my $out, ">", \my $out_buf; $DB::OUT = $out; open my $in, "<", \my $in_buf; $DB::IN = $in; } require "$Bin/../../t/type_constraints/duck_types.t"; test-my-dependents.t100644000767000024 7335012200352344 20237 0ustar00etherstaff000000000000Moose-2.1005/xt/authoruse strict; use warnings; use Cwd qw( abs_path ); use Test::More; BEGIN { my $help = <<'EOF'; This test will not run unless you set MOOSE_TEST_MD to a true value. Valid values are: all Test every dist which depends on Moose except those that we know cannot be tested. This is a lot of distros (thousands). Dist::1,Dist::2,... Test the individual dists listed. MooseX Test all Moose extension distros (MooseX modules plus a few others). 1 Run the default tests. We pick 200 random dists and test them. EOF plan skip_all => $help unless $ENV{MOOSE_TEST_MD}; } use Test::Requires { 'Archive::Zip' => 0, # or else .zip dists won't be able to be installed 'Test::DependentModules' => '0.13', 'MetaCPAN::API' => '0.33', }; use Test::DependentModules qw( test_module ); use DateTime; use List::MoreUtils qw(any); use Moose (); diag( 'Test run performed at: ' . DateTime->now . ' with Moose ' . (Moose->VERSION || 'git repo') ); $ENV{PERL_TEST_DM_LOG_DIR} = abs_path('.'); delete @ENV{ qw( AUTHOR_TESTING RELEASE_TESTING SMOKE_TESTING ) }; $ENV{ANY_MOOSE} = 'Moose'; my $mcpan = MetaCPAN::API->new; my $res = $mcpan->post( '/release/_search' => { query => { match_all => {} }, size => 5000, filter => { and => [ { or => [ { term => { 'release.dependency.module' => 'Moose' } }, { term => { 'release.dependency.module' => 'Moose::Role' } }, { term => { 'release.dependency.module' => 'Moose::Exporter' } }, { term => { 'release.dependency.module' => 'Class::MOP' } }, { term => { 'release.dependency.module' => 'MooseX::Role::Parameterized' } }, { term => { 'release.dependency.module' => 'Any::Moose' } }, ] }, { term => { 'release.status' => 'latest' } }, { term => { 'release.maturity' => 'released' } }, ] }, fields => 'distribution' } ); my @skip_prefix = qw(Acme Task Bundle); my %skip; my %todo; my $hash; for my $line () { chomp $line; next unless $line =~ /\S/; if ( $line =~ /^# (\w+)/ ) { die "Invalid action in DATA section ($1)" unless $1 eq 'SKIP' || $1 eq 'TODO'; $hash = $1 eq 'SKIP' ? \%skip : \%todo; } my ( $dist, $reason ) = $line =~ /^(\S*)\s*(?:#\s*(.*)\s*)?$/; next unless defined $dist && length $dist; $hash->{$dist} = $reason; } my %name_fix = ( 'App-passmanager' => 'App::PassManager', 'App-PipeFilter' => 'App::PipeFilter::Generic', 'Constructible' => 'Constructible::Maxima', 'DCOLLINS-ANN-Locals' => 'DCOLLINS::ANN::Robot', 'Dist-Zilla-Deb' => 'Dist::Zilla::Plugin::Deb::VersionFromChangelog', 'Dist-Zilla-Plugins-CJM' => 'Dist::Zilla::Plugin::TemplateCJM', 'Dist-Zilla-Plugin-TemplateFile' => 'Dist::Zilla::Plugin::TemplateFiles', 'Google-Directions' => 'Google::Directions::Client', 'helm' => 'Helm', 'HTML-Untemplate' => 'HTML::Linear', 'marc-moose' => 'MARC::Moose', 'mobirc' => 'App::Mobirc', 'OWL-Simple' => 'OWL::Simple::Class', 'Patterns-ChainOfResponsibility' => 'Patterns::ChainOfResponsibility::Application', 'Pod-Elemental-Transfomer-VimHTML' => 'Pod::Elemental::Transformer::VimHTML', 'Role-Identifiable' => 'Role::Identifiable::HasIdent', 'smokebrew' => 'App::SmokeBrew', 'Treex-Parser-MSTperl' => 'Treex::Tool::Parser::MSTperl', 'v6-alpha' => 'v6', 'WebService-LOC-CongRec' => 'WebService::LOC::CongRec::Crawler', 'X11-XCB' => 'X11::XCB::Connection', 'XML-Ant-BuildFile' => 'XML::Ant::BuildFile::Project', ); my @dists = sort grep { !$skip{$_} } grep { my $dist = $_; !any { $dist =~ /^$_-/ } @skip_prefix } map { $_->{fields}{distribution} } @{ $res->{hits}{hits} }; if ( $ENV{MOOSE_TEST_MD} eq 'MooseX' ) { @dists = grep { /^(?:MooseX-|(?:Fey-ORM|KiokuDB|Bread-Board|Catalyst-Runtime|Reflex)$)/ } @dists; } elsif ( $ENV{MOOSE_TEST_MD} eq '1' ) { diag( <<'EOF' Picking 200 random dependents to test. Set MOOSE_TEST_MD=all to test all dependents or MOOSE_TEST_MD=MooseX to test extension modules only. EOF ); my %indexes; while ( keys %indexes < 200 ) { $indexes{ int rand( scalar @dists ) } = 1; } @dists = @dists[ sort keys %indexes ]; } elsif ( $ENV{MOOSE_TEST_MD} ne 'all' ) { my @chosen = split /,/, $ENV{MOOSE_TEST_MD}; my %dists = map { $_ => 1 } @dists; if (my @unknown = grep { !$dists{$_} } @chosen) { die "Unknown dists: @unknown"; } @dists = @chosen; } plan tests => scalar @dists; for my $dist (@dists) { note($dist); my $module = $dist; $module = $name_fix{$module} if exists $name_fix{$module}; if ($todo{$dist}) { my $reason = $todo{$dist}; $reason = '???' unless defined $reason; local $TODO = $reason; eval { test_module($module); 1 } or fail("Died when testing $module: $@"); } else { eval { test_module($module); 1 } or fail("Died when testing $module: $@"); } } __DATA__ # SKIP: indexing issues (test::dm bugs?) Alice # couldn't find on cpan Hopkins # couldn't find on cpan PostScript-Barcode # couldn't find on cpan WWW-Mechanize-Query # couldn't find on cpan # SKIP: doesn't install deps properly (test::dm bugs?) App-Benchmark-Accessors # Mojo::Base isn't installed Bot-BasicBot-Pluggable # Crypt::SaltedHash isn't installed Code-Statistics # MooseX::HasDefaults::RO isn't installed Dist-Zilla-PluginBundle-MITHALDU # List::AllUtils isn't installed Dist-Zilla-Util-FileGenerator # MooseX::HasDefaults::RO isn't installed EBI-FGPT-FuzzyRecogniser # GO::Parser isn't installed Erlang-Parser # Parse::Yapp::Driver isn't installed Foorum # Sphinx::Search isn't installed Grimlock # DBIx::Class::EncodedColumn isn't installed Locale-Handle-Pluggable # MooseX::Types::VariantTable::Declare isn't installed mobirc # HTTP::Session::State::GUID isn't installed Net-Bamboo # XML::Tidy isn't installed Tatsumaki-Template-Markapl # Tatsumaki::Template isn't installed Text-Tradition # Bio::Phylo::IO isn't installed WebService-Strava # Any::URI::Escape isn't installed # SKIP: no tests AI-ExpertSystem-Advanced # no tests API-Assembla # no tests App-mkfeyorm # no tests App-passmanager # no tests App-Scrobble # no tests Bot-Applebot # no tests Catalyst-Authentication-Credential-Facebook-OAuth2 # no tests Catalyst-Authentication-Store-Fey-ORM # no tests Catalyst-Controller-MovableType # no tests Catalyst-Model-MenuGrinder # no tests Chef # no tests Data-SearchEngine-ElasticSearch # no tests Dist-Zilla-MintingProfile-Author-ARODLAND # no tests Dist-Zilla-PluginBundle-ARODLAND # no tests Dist-Zilla-PluginBundle-Author-OLIVER # no tests Dist-Zilla-PluginBundle-NUFFIN # no tests Dist-Zilla-Plugin-DualLife # no tests Dist-Zilla-Plugin-Git-Describe # no tests Dist-Zilla-Plugin-GitFlow # no tests Dist-Zilla-Plugin-GitFmtChanges # no tests Dist-Zilla-Plugin-MetaResourcesFromGit # no tests Dist-Zilla-Plugin-ModuleBuild-OptionalXS # no tests Dist-Zilla-Plugin-Rsync # no tests Dist-Zilla-Plugin-TemplateFile # no tests Dist-Zilla-Plugin-UploadToDuckPAN # no tests Finance-Bank-SuomenVerkkomaksut # no tests Games-HotPotato # no tests IO-Storm # no tests JIRA-Client-REST # no tests Kafka-Client # no tests LWP-UserAgent-OfflineCache # no tests Markdown-Pod # no tests MooseX-Types-DateTimeX # no tests MooseX-Types-DateTime-MoreCoercions # no tests unless DateTime::Format::DateManip is installed Net-Azure-BlobService # no tests Net-Dropbox # no tests Net-Flowdock # no tests Net-OpenStack-Attack # no tests Net-Ostrich # no tests Net-Recurly # no tests OpenDocument-Template # no tests Pod-Weaver-Section-Consumes # no tests Pod-Weaver-Section-Encoding # no tests Pod-Weaver-Section-Extends # no tests P50Tools # no tests POE-Component-Server-MySQL # no tests Random-Quantum # no tests SchemaEvolution # no tests STD # no tests Test-System # no tests Test-WWW-Mechanize-Dancer # no tests WebService-Buxfer # no tests WebService-CloudFlare-Host # no tests WWW-MenuGrinder # no tests WWW-WuFoo # no tests # SKIP: external dependencies Alien-Ditaa # runs java code Ambrosia # required mod_perl AnyEvent-MSN # requires Net::SSLeay (which requires libssl) AnyEvent-Multilog # requires multilog AnyEvent-Net-Curl-Queued # requires libcurl AnyEvent-ZeroMQ # requires zeromq installation AnyMQ-ZeroMQ # requires zeromq installation Apache2-HttpEquiv # requires apache (for mod_perl) App-Mimosa # requires fastacmd App-PgCryobit # requires postgres installation App-SimplenoteSync # requires File::ExtAttr which requires libattr Archive-RPM # requires cpio Bot-Jabbot # requires libidn Catalyst-Engine-Stomp # depends on alien::activemq Catalyst-Plugin-Session-Store-Memcached # requires memcached Cave-Wrapper # requires cave to be installed CHI-Driver-Redis # requires redis server Crypt-Random-Source-Strong-Win32 # windows only Curses-Toolkit # requires Curses which requires ncurses library Dackup # requires ssh Data-Collector # requires ssh Data-Riak # requires riak DBIx-PgLink # requires postgres installation Dist-Zilla-Plugin-Subversion # requires svn bindings Dist-Zilla-Plugin-SVK # requires svn bindings Dist-Zilla-Plugin-SvnObtain # requires svn bindings Fedora-App-MaintainerTools # requires rpm to be installed Fedora-App-ReviewTool # requires koji to be installed Fuse-Template # requires libfuse Games-HotPotato # requires sdl Games-Tetris-Complete # requires threads helm # requires ssh HTML-Barcode-QRCode # requires libqrencode IRC-RemoteControl # requires libssh2 JavaScript-Sprockets # requires sprocketize JavaScript-V8x-TestMoreish # requires v8 Koha-Contrib-Tamil # requires yaz K # requires kx Lighttpd-Control # requires lighttpd Lingua-TreeTagger # requires treetagger to be installed Math-Lsoda # requires f77 Message-Passing-ZeroMQ # requires zeromq installation MongoDBI # requires mongo MongoDB # requires mongo MSWord-ToHTML # requires abiword to be installed Net-DBus-Skype # requires dbus Net-Route # requires route Net-SFTP-Foreign-Exceptional # depends on running ssh Net-UpYun # requires curl Net-ZooTool # requires curl Nginx-Control # requires nginx to be installed NLP-Service # requires javac Padre-Plugin-Cookbook # requires Wx Padre-Plugin-Moose # requires threaded perl Padre-Plugin-PDL # requires threaded perl Padre-Plugin-Snippet # requires threaded perl Paludis-UseCleaner # depends on cave::wrapper Perlanet # HTML::Tidy requires tidyp Perl-Dist-Strawberry-BuildPerl-5123 # windows only Perl-Dist-Strawberry-BuildPerl-5123 # windows only Perl-Dist-WiX-BuildPerl-5123 # windows only Perl-Dist-WiX # windows only Perl-Dist-WiX # windows only POE-Component-OpenSSH # requires ssh RDF-TrineX-RuleEngine-Jena # requires Jena SimpleDB-Class # requires memcached SVN-Simple-Hook # requires svn SVN-Tree # requires svn Tapper-MCP # depends on everything under the sun - some of which is broken Template-JavaScript # requires v8 TheSchwartz-Moosified # requires DBI::Pg ? WebService-SendGrid # requires curl WebService-Tesco-API # requires curl WWW-Contact # depends on curl WWW-Curl-Simple # requires curl ZeroMQ-PubSub # requires zmq ZMQ-Declare # requires zmq # SKIP: flaky internet tests iTransact-Lite # tests rely on internet site Unicode-Emoji-E4U # tests rely on internet site WWW-eNom # tests rely on internet site WWW-Finances-Bovespa # tests rely on internet site WWW-Vimeo-Download # tests rely on internet site WWW-YouTube-Download-Channel # tests rely on internet site # SKIP: graphical App-CPAN2Pkg # tk tests are graphical App-USBKeyCopyCon # gtk tests are graphical CatalystX-Restarter-GTK # gtk tests are graphical Forest-Tree-Viewer-Gtk2 # gtk tests are graphical Games-Pandemic # tk tests are graphical Games-RailRoad # tk tests are graphical Games-Risk # tk tests are graphical Log-Dispatch-Gtk2-Notify # gtk tests are graphical LPDS # gtk tests are graphical Periscope # gtk tests are graphical Tk-Role-Dialog # tk tests are graphical Weaving-Tablet # tk tests are graphical # SKIP: prompts (or a dep prompts) or does something else dumb Bot-Backbone # poe-loop-ev prompts Cache-Ehcache # hangs if server exists on port 8080 CM-Permutation # OpenGL uses graphics in Makefile.PL Date-Biorhythm # Date::Business prompts in Makefile.PL DBIx-VersionedDDL # runs a script with /usr/bin/perl in the shbang line File-Tail-Scribe # tests hang Gearman-Driver # spews tar errors Gearman-SlotManager # tests hang IPC-AnyEvent-Gearman # tests hang Lingua-YALI # runs scripts with /usr/bin/env perl in the shbang line Net-SSH-Mechanize # the mock-ssh script it runs seems to spin endlessly POE-Component-Server-SimpleHTTP-PreFork # tests hang WWW-Hashdb # test hangs, pegging cpu Zucchini # File::Rsync prompts in Makefile.PL # TODO: failing for a reason Algorithm-KernelKMeans # mx-types-common changes broke it AnyEvent-BitTorrent # broken AnyEvent-Cron # intermittent failures AnyEvent-Inotify-Simple # ??? (maybe issue with test::sweet) AnyEvent-JSONRPC # tests require recommended deps AnyEvent-Retry # mx-types-common changes broke it AnyMongo # doesn't compile App-ArchiveDevelCover # depends on nonexistent testdata::setup App-Dataninja # bad M::I install in inc/ App-Fotagger # Imager doesn't compile App-Magpie # deps on URPM which doesn't exist App-MediaWiki2Git # git::repository is broken App-Munchies # depends on XML::DTD App-TemplateServer # broken use of types App-TemplateServer-Provider-HTML-Template # dep on app-templateserver App-TemplateServer-Provider-Mason # dep on app-templateserver App-TemplateServer-Provider-TD # dep on app-templateserver App-Twimap # dep on Web::oEmbed::Common App-Validation-Automation # dep on Switch App-Wubot # broken Beagle # depends on term::readline::perl Cache-Profile # broken Catalyst-Authentication-Store-LDAP-AD-Class # pod coverage fail Catalyst-Controller-Resources # broken Catalyst-Controller-SOAP # broken Catalyst-Model-Sedna # deps on Alien-Sedna which doesn't exist Catalyst-Plugin-Continuation # undeclared dep Catalyst-Plugin-Session-State-Cookie # broken Catalyst-Plugin-Session-Store-TestMemcached # dep with corrupt archive Catalyst-Plugin-SwiffUploaderCookieHack # undeclared dep Catalyst-TraitFor-Request-PerLanguageDomains # dep on ::State::Cookie CatalystX-ExtJS-Direct # broken CatalystX-I18N # dep on ::State::Cookie CatalystX-MooseComponent # broken CatalystX-SimpleLogin # broken CatalystX-Usul # proc::processtable doesn't load Cheater # parse::randgen is broken Class-OWL # uses CMOP::Class without loading cmop Cogwheel # uses ancient moose apis Config-Model # broken Config-Model-Backend-Augeas # deps on Config::Model Config-Model-OpenSsh # deps on Config::Model Constructible # GD::SVG is a broken dist Constructible-Maxima # GD::SVG is a broken dist Coro-Amazon-SimpleDB # amazon::simpledb::client doesn't exist CPAN-Digger # requires DBD::SQLite Data-AMF # missing dep on YAML Data-Apache-mod_status # invalid characters in type name Data-Edit # dist is missing some modules Data-Feed # broken (only sometimes?) Data-PackageName # broken Data-Pipeline # uses ancient moose apis Data-SCORM # pod coverage fail DayDayUp # MojoX-Fixup-XHTML doesn't exist DBICx-Modeler-Generator # broken (weirdly) DBIx-SchemaChecksum # broken Debian-Apt-PM # configure time failures Devel-Events # broken (role conflict) Dist-Zilla-Deb # pod coverage fail Dist-Zilla-Plugin-ChangelogFromGit-Debian # git::repository is broken Dist-Zilla-Plugin-CheckChangesHasContent # broken Dist-Zilla-Plugin-Git # tests fail when run in a temp dir Dist-Zilla-Plugin-PerlTidy # expects to find dzil in the path Dist-Zilla-Plugin-Pinto-Add # deps on Pinto::Common Dist-Zilla-Plugin-ProgCriticTests # broken Dist-Zilla-Plugin-Test-ReportPrereqs # broken DustyDB # uses old moose apis Dwimmer # broken Facebook-Graph # broken FCGI-Engine # runs scripts without using $^X Fedora-Bugzilla # deps on nonexistent things FFmpeg-Thumbnail # undeclared dep File-DataClass # XML::DTD is a broken dist File-Stat-Moose # old moose apis File-Tail-Dir # intermittent fails (i think) Form-Factory # uses old moose apis Form-Sensible # broken FormValidator-Nested # broken Frost # broken Games-Dice-Loaded # flaky tests Gitalist # broken GOBO # coerce with no coercion Google-Chart # recreating type constraints Google-Spreadsheet-Agent # pod::coverage fail Hobocamp # configure_requires needs EU::CChecker Horris # App::Horris isn't on cpan HTML-Grabber # pod::coverage fail HTML-TreeBuilderX-ASP_NET # broken HTTP-Engine-Middleware # missing dep on yaml Image-Robohash # Graphics::Magick doesn't exist JavaScript-Framework-jQuery # coerce with no coercion Jenkins-NotificationListener # missing dep on File::Read Jifty # Test::WWW::Selenium needs devel::repl JSORB # broken Jungle # broken Kamaitachi # pod::coverage fail KiokuDB-Backend-Files # broken LaTeX-TikZ # broken (with moose) marc-moose # broken (only sometimes?) Mail-Summary-Tools # DT::Format::DateManip is broken MediaWiki-USERINFO # broken Metabase-Backend-MongoDB # broken Metabase-Backend-SQL # broken (I think) Method-Signatures # doesn't like ANY_MOOSE=Moose mobirc # http::engine broken MooseX-Attribute-Prototype # uses old moose apis MooseX-DBIC-Scaffold # needs unreleased sql-translator MooseX-Documenter # broken MooseX-DOM # "no Moose" unimports confess MooseX-Error-Exception-Class # metaclass compat breakage MooseX-Getopt-Usage # missing dep on Test::Class MooseX-GTIN # broken (under jenkins, at least) MooseX-Meta-Attribute-Index # old moose apis MooseX-Meta-Attribute-Lvalue # old moose apis MooseX-Role-XMLRPC-Client # requires LWP::Protocol::http which requires libssl MooseX-Scaffold # broken MooseX-Struct # ancient moose apis MooseX-Types-Parameterizable # broken MooseX-WithCache # broken MouseX-Types # broken (with moose) MySQL-Util # pod-coverage fail Nagios-Passive # broken Net-APNS # broken (with moose) Net-FluidDB # broken Net-Fluidinfo # broken Net-Google-Blogger # broken Net-Google-FederatedLogin # broken NetHack-Item # NH::Monster::Spoiler is broken NetHack-Monster-Spoiler # broken (MX::CA issues) Net-HTTP-Factual # broken Net-Jabber-Bot # broken Net-Journyx # broken Net-Mollom # broken Net-Parliament # broken Net-Plurk # broken Net-SSLeay-OO # broken Net-StackExchange # broken Norma # fails when trying to write to a read-only SQLite db file under jenkins, also fails when run manually ODG-Record # Test::Benchmark broken Perlbal-Control # proc::processtable doesn't load Pg-BulkCopy # hardcodes /usr/bin/perl Pinto-Common # broken Pinto-Remove # deps on Pinto::Common Pinto-Server # deps on Pinto::Common Plack-Middleware-Image-Scale # Image::Scale is broken Pod-Parser-I18N # missing dep on Data::Localize POE-Component-CPAN-Mirror-Multiplexer # broken POE-Component-DirWatch # intermittent failures POE-Component-DirWatch-Object # intermittent failures POE-Component-ResourcePool # broken POE-Component-Server-PSGI # broken deps POE-Component-Server-SimpleHTTP-PreFork # broken deps Poet # missing dep on Log::Any::Adapter::Log4perl POEx-ProxySession # broken deps POEx-PubSub # broken deps POEx-WorkerPool # broken deps PostScript-ScheduleGrid-XMLTV # XMLTV doesn't exist PRANG # broken Prophet # depends on term::readline::perl Queue-Leaky # broken Railsish # dep on nonexistent dist RDF-Server # "no Moose" unimports confess Reaction # signatures is broken Reflexive-Role-DataMover # broken (reflex::role changes?) Reflexive-Role-TCPServer # broken (reflex::role changes?) Reflexive-Stream-Filtering # broken RPC-Any # broken Scene-Graph # has '+attr' in roles Server-Control # proc::processtable doesn't load Shipment # locale::subcountry is broken Silki # image::magick is broken SilkiX-Converter-Kwiki # file::mimeinfo expects (?-xism: Sloth # rest::utils is broken Sque # couldn't fork server for testing SRS-EPP-Proxy # depends on xml::epp String-Blender # broken TAEB # broken Tail-Tool # Getopt::Alt doesn't exist Tapper-CLI # sys::info::driver::linux is broken Tapper-Installer # sys::info::driver::linux is broken Tapper-MCP-MessageReceiver # sys::info::driver::linux is broken Tapper-Reports-API # sys::info::driver::linux is broken Tapper-Testplan # sys::info::driver::linux is broken Telephone-Mnemonic-US # rpm-build-perl is broken Template-Plugin-Heritable # weird dep issues (not test::dm related) Test-A8N # broken Test-Daily # configure errors Test-Pockito # broken Test-SFTP # Term::ReadPassword prompts in tests Test-WWW-Selenium-More # Test::WWW::Selenium needs devel::repl Text-Clevery # broken Text-Zilla # broken Thorium # depends on Hobocamp TryCatch-Error # broken Verby # deps on poe::component::resourcepool Weather-TW # missing dep on Mojo::DOM Web-API-Mapper # broken WebNano-Controller-CRUD # broken Webservice-Intermine # broken tests WebService-Yes24 # broken WiX3 # broken WWW-Alltop # XML::SimpleObject configure fail WWW-Comix # uses ancient Moose::Policy stuff WWW-DataWiki # broken WWW-Fandango # bad dist WWW-FMyLife # broken WWW-Mechanize-Cached # tries to read from wrong build dir? WWW-Metalgate # Cache is broken WWW-Scramble # pod::coverage fail WWW-Sitemapper # broken WWW-StaticBlog # time::sofar is broken WWW-WebKit # missing configure_req on EU::PkgConfig WWW-Yahoo-Lyrics-JP # broken XIRCD # undeclared deps XML-EPP # coerce without coercion XML-SRS # deps on prang XML-Writer-Compiler # broken tests Yukki # git::repository is broken type_constraints2.pl100644000767000024 600412200352344 20500 0ustar00etherstaff000000000000Moose-2.1005/benchmarks#!/usr/bin/perl use strict; use warnings; use Benchmark qw[timethese]; =pod This benchmark is designed to measure how long things with type constraints take (constructors, accessors). It was created to measure the impact of inlining type constraints. =cut { package Thing; use Moose; has int => ( is => 'rw', isa => 'Int', ); has str => ( is => 'rw', isa => 'Str', ); has fh => ( is => 'rw', isa => 'FileHandle', ); has object => ( is => 'rw', isa => 'Object', ); has a_int => ( is => 'rw', isa => 'ArrayRef[Int]', ); has a_str => ( is => 'rw', isa => 'ArrayRef[Str]', ); has a_fh => ( is => 'rw', isa => 'ArrayRef[FileHandle]', ); has a_object => ( is => 'rw', isa => 'ArrayRef[Object]', ); has h_int => ( is => 'rw', isa => 'HashRef[Int]', ); has h_str => ( is => 'rw', isa => 'HashRef[Str]', ); has h_fh => ( is => 'rw', isa => 'HashRef[FileHandle]', ); has h_object => ( is => 'rw', isa => 'HashRef[Object]', ); __PACKAGE__->meta->make_immutable; } { package Simple; use Moose; has str => ( is => 'rw', isa => 'Str', ); __PACKAGE__->meta->make_immutable; } my @ints = 1 .. 10; my @strs = 'a' .. 'j'; my @fhs = map { my $fh; open $fh, '<', $0 or die; $fh; } 1 .. 10; my @objects = map { Thing->new } 1 .. 10; my %ints = map { $_ => $_ } @ints; my %strs = map { $_ => $_ } @ints; my %fhs = map { $_ => $_ } @fhs; my %objects = map { $_ => $_ } @objects; my $thing = Thing->new; my $simple = Simple->new; timethese( 1_000_000, { constructor_simple => sub { Simple->new( str => $strs[0] ); }, accessors_simple => sub { $simple->str( $strs[0] ); }, } ); timethese( 20_000, { constructor_all => sub { Thing->new( int => $ints[0], str => $strs[0], fh => $fhs[0], object => $objects[0], a_int => \@ints, a_str => \@strs, a_fh => \@fhs, a_object => \@objects, h_int => \%ints, h_str => \%strs, h_fh => \%fhs, h_object => \%objects, ); }, accessors_all => sub { $thing->int( $ints[0] ); $thing->str( $strs[0] ); $thing->fh( $fhs[0] ); $thing->object( $objects[0] ); $thing->a_int( \@ints ); $thing->a_str( \@strs ); $thing->a_fh( \@fhs ); $thing->a_object( \@objects ); $thing->h_int( \%ints ); $thing->h_str( \%strs ); $thing->h_fh( \%fhs ); $thing->h_object( \%objects ); }, } ); Inlined.pm100644000767000024 773212200352344 17753 0ustar00etherstaff000000000000Moose-2.1005/lib/Class/MOP/Methodpackage Class::MOP::Method::Inlined; BEGIN { $Class::MOP::Method::Inlined::AUTHORITY = 'cpan:STEVAN'; } { $Class::MOP::Method::Inlined::VERSION = '2.1005'; } use strict; use warnings; use Carp 'confess'; use Scalar::Util 'blessed', 'weaken', 'looks_like_number', 'refaddr'; use base 'Class::MOP::Method::Generated'; sub _uninlined_body { my $self = shift; my $super_method = $self->associated_metaclass->find_next_method_by_name( $self->name ) or return; if ( $super_method->isa(__PACKAGE__) ) { return $super_method->_uninlined_body; } else { return $super_method->body; } } sub can_be_inlined { my $self = shift; my $metaclass = $self->associated_metaclass; my $class = $metaclass->name; # If we don't find an inherited method, this is a rather weird # case where we have no method in the inheritance chain even # though we're expecting one to be there my $inherited_method = $metaclass->find_next_method_by_name( $self->name ); if ( $inherited_method && $inherited_method->isa('Class::MOP::Method::Wrapped') ) { warn "Not inlining '" . $self->name . "' for $class since it " . "has method modifiers which would be lost if it were inlined\n"; return 0; } my $expected_class = $self->_expected_method_class or return 1; # if we are shadowing a method we first verify that it is # compatible with the definition we are replacing it with my $expected_method = $expected_class->can( $self->name ); if ( ! $expected_method ) { warn "Not inlining '" . $self->name . "' for $class since ${expected_class}::" . $self->name . " is not defined\n"; return 0; } my $actual_method = $class->can( $self->name ) or return 1; # the method is what we wanted (probably Moose::Object::new) return 1 if refaddr($expected_method) == refaddr($actual_method); # otherwise we have to check that the actual method is an inlined # version of what we're expecting if ( $inherited_method->isa(__PACKAGE__) ) { if ( $inherited_method->_uninlined_body && refaddr( $inherited_method->_uninlined_body ) == refaddr($expected_method) ) { return 1; } } elsif ( refaddr( $inherited_method->body ) == refaddr($expected_method) ) { return 1; } my $warning = "Not inlining '" . $self->name . "' for $class since it is not" . " inheriting the default ${expected_class}::" . $self->name . "\n"; if ( $self->isa("Class::MOP::Method::Constructor") ) { # FIXME kludge, refactor warning generation to a method $warning .= "If you are certain you don't need to inline your" . " constructor, specify inline_constructor => 0 in your" . " call to $class->meta->make_immutable\n"; } warn $warning; return 0; } 1; # ABSTRACT: Method base class for methods which have been inlined __END__ =pod =head1 NAME Class::MOP::Method::Inlined - Method base class for methods which have been inlined =head1 VERSION version 2.1005 =head1 DESCRIPTION This is a L subclass for methods which can be inlined. =head1 METHODS =over 4 =item B<< $metamethod->can_be_inlined >> This method returns true if the method in question can be inlined in the associated metaclass. If it cannot be inlined, it spits out a warning and returns false. =back =head1 AUTHOR Moose is maintained by the Moose Cabal, along with the help of many contributors. See L and L for details. =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2013 by Infinity Interactive, Inc.. This is free software; you can redistribute it and/or modify it under the same terms as the Perl 5 programming language system itself. =cut Wrapped.pm100644000767000024 1772012200352344 20011 0ustar00etherstaff000000000000Moose-2.1005/lib/Class/MOP/Method package Class::MOP::Method::Wrapped; BEGIN { $Class::MOP::Method::Wrapped::AUTHORITY = 'cpan:STEVAN'; } { $Class::MOP::Method::Wrapped::VERSION = '2.1005'; } use strict; use warnings; use Carp 'confess'; use Scalar::Util 'blessed'; use base 'Class::MOP::Method'; # NOTE: # this ugly beast is the result of trying # to micro optimize this as much as possible # while not completely loosing maintainability. # At this point it's "fast enough", after all # you can't get something for nothing :) my $_build_wrapped_method = sub { my $modifier_table = shift; my ($before, $after, $around) = ( $modifier_table->{before}, $modifier_table->{after}, $modifier_table->{around}, ); if (@$before && @$after) { $modifier_table->{cache} = sub { for my $c (@$before) { $c->(@_) }; my @rval; ((defined wantarray) ? ((wantarray) ? (@rval = $around->{cache}->(@_)) : ($rval[0] = $around->{cache}->(@_))) : $around->{cache}->(@_)); for my $c (@$after) { $c->(@_) }; return unless defined wantarray; return wantarray ? @rval : $rval[0]; } } elsif (@$before && !@$after) { $modifier_table->{cache} = sub { for my $c (@$before) { $c->(@_) }; return $around->{cache}->(@_); } } elsif (@$after && !@$before) { $modifier_table->{cache} = sub { my @rval; ((defined wantarray) ? ((wantarray) ? (@rval = $around->{cache}->(@_)) : ($rval[0] = $around->{cache}->(@_))) : $around->{cache}->(@_)); for my $c (@$after) { $c->(@_) }; return unless defined wantarray; return wantarray ? @rval : $rval[0]; } } else { $modifier_table->{cache} = $around->{cache}; } }; sub wrap { my ( $class, $code, %params ) = @_; (blessed($code) && $code->isa('Class::MOP::Method')) || confess "Can only wrap blessed CODE"; my $modifier_table = { cache => undef, orig => $code->body, before => [], after => [], around => { cache => $code->body, methods => [], }, }; $_build_wrapped_method->($modifier_table); return $class->SUPER::wrap( sub { $modifier_table->{cache}->(@_) }, # get these from the original # unless explicitly overridden package_name => $params{package_name} || $code->package_name, name => $params{name} || $code->name, original_method => $code, modifier_table => $modifier_table, ); } sub _new { my $class = shift; return Class::MOP::Class->initialize($class)->new_object(@_) if $class ne __PACKAGE__; my $params = @_ == 1 ? $_[0] : {@_}; return bless { # inherited from Class::MOP::Method 'body' => $params->{body}, 'associated_metaclass' => $params->{associated_metaclass}, 'package_name' => $params->{package_name}, 'name' => $params->{name}, 'original_method' => $params->{original_method}, # defined in this class 'modifier_table' => $params->{modifier_table} } => $class; } sub get_original_method { my $code = shift; $code->original_method; } sub add_before_modifier { my $code = shift; my $modifier = shift; unshift @{$code->{'modifier_table'}->{before}} => $modifier; $_build_wrapped_method->($code->{'modifier_table'}); } sub before_modifiers { my $code = shift; return @{$code->{'modifier_table'}->{before}}; } sub add_after_modifier { my $code = shift; my $modifier = shift; push @{$code->{'modifier_table'}->{after}} => $modifier; $_build_wrapped_method->($code->{'modifier_table'}); } sub after_modifiers { my $code = shift; return @{$code->{'modifier_table'}->{after}}; } { # NOTE: # this is another possible candidate for # optimization as well. There is an overhead # associated with the currying that, if # eliminated might make around modifiers # more manageable. my $compile_around_method = sub {{ my $f1 = pop; return $f1 unless @_; my $f2 = pop; push @_, sub { $f2->( $f1, @_ ) }; redo; }}; sub add_around_modifier { my $code = shift; my $modifier = shift; unshift @{$code->{'modifier_table'}->{around}->{methods}} => $modifier; $code->{'modifier_table'}->{around}->{cache} = $compile_around_method->( @{$code->{'modifier_table'}->{around}->{methods}}, $code->{'modifier_table'}->{orig} ); $_build_wrapped_method->($code->{'modifier_table'}); } } sub around_modifiers { my $code = shift; return @{$code->{'modifier_table'}->{around}->{methods}}; } sub _make_compatible_with { my $self = shift; my ($other) = @_; # XXX: this is pretty gross. the issue here is that CMOP::Method::Wrapped # objects are subclasses of CMOP::Method, but when we get to moose, they'll # need to be compatible with Moose::Meta::Method, which isn't possible. the # right solution here is to make ::Wrapped into a role that gets applied to # whatever the method_metaclass happens to be and get rid of # wrapped_method_metaclass entirely, but that's not going to happen until # we ditch cmop and get roles into the bootstrapping, so. i'm not # maintaining the previous behavior of turning them into instances of the # new method_metaclass because that's equally broken, and at least this way # any issues will at least be detectable and potentially fixable. -doy return $self unless $other->_is_compatible_with($self->_real_ref_name); return $self->SUPER::_make_compatible_with(@_); } 1; # ABSTRACT: Method Meta Object for methods with before/after/around modifiers __END__ =pod =head1 NAME Class::MOP::Method::Wrapped - Method Meta Object for methods with before/after/around modifiers =head1 VERSION version 2.1005 =head1 DESCRIPTION This is a L subclass which implements before, after, and around method modifiers. =head1 METHODS =head2 Construction =over 4 =item B<< Class::MOP::Method::Wrapped->wrap($metamethod, %options) >> This is the constructor. It accepts a L object and a hash of options. The options are: =over 8 =item * name The method name (without a package name). This will be taken from the provided L object if it is not provided. =item * package_name The package name for the method. This will be taken from the provided L object if it is not provided. =item * associated_metaclass An optional L object. This is the metaclass for the method's class. =back =item B<< $metamethod->get_original_method >> This returns the L object that was passed to the constructor. =item B<< $metamethod->add_before_modifier($code) >> =item B<< $metamethod->add_after_modifier($code) >> =item B<< $metamethod->add_around_modifier($code) >> These methods all take a subroutine reference and apply it as a modifier to the original method. =item B<< $metamethod->before_modifiers >> =item B<< $metamethod->after_modifiers >> =item B<< $metamethod->around_modifiers >> These methods all return a list of subroutine references which are acting as the specified type of modifier. =back =head1 AUTHOR Moose is maintained by the Moose Cabal, along with the help of many contributors. See L and L for details. =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2013 by Infinity Interactive, Inc.. This is free software; you can redistribute it and/or modify it under the same terms as the Perl 5 programming language system itself. =cut Attributes.pod100644000767000024 4676712200352344 20277 0ustar00etherstaff000000000000Moose-2.1005/lib/Moose/Manualpackage Moose::Manual::Attributes; # ABSTRACT: Object attributes with Moose __END__ =pod =head1 NAME Moose::Manual::Attributes - Object attributes with Moose =head1 VERSION version 2.1005 =head1 INTRODUCTION Moose attributes have many properties, and attributes are probably the single most powerful and flexible part of Moose. You can create a powerful class simply by declaring attributes. In fact, it's possible to have classes that consist solely of attribute declarations. An attribute is a property that every member of a class has. For example, we might say that "every C object has a first name and last name". Attributes can be optional, so that we can say "some C objects have a social security number (and some don't)". At its simplest, an attribute can be thought of as a named value (as in a hash) that can be read and set. However, attributes can also have defaults, type constraints, delegation and much more. In other languages, attributes are also referred to as slots or properties. =head1 ATTRIBUTE OPTIONS Use the C function to declare an attribute: package Person; use Moose; has 'first_name' => ( is => 'rw' ); This says that all C objects have an optional read-write "first_name" attribute. =head2 Read-write vs. read-only The options passed to C define the properties of the attribute. There are many options, but in the simplest form you just need to set C, which can be either C (read-only) or C (read-write). When an attribute is C, you can change it by passing a value to its accessor. When an attribute is C, you may only read the current value of the attribute. In fact, you could even omit C, but that gives you an attribute that has no accessor. This can be useful with other attribute options, such as C. However, if your attribute generates I accessors, Moose will issue a warning, because that usually means the programmer forgot to say the attribute is read-only or read-write. If you really mean to have no accessors, you can silence this warning by setting C to C. =head2 Accessor methods Each attribute has one or more accessor methods. An accessor lets you read and write the value of that attribute for an object. By default, the accessor method has the same name as the attribute. If you declared your attribute as C then your accessor will be read-only. If you declared it as C, you get a read-write accessor. Simple. Given our C example above, we now have a single C accessor that can read or write a C object's C attribute's value. If you want, you can also explicitly specify the method names to be used for reading and writing an attribute's value. This is particularly handy when you'd like an attribute to be publicly readable, but only privately settable. For example: has 'weight' => ( is => 'ro', writer => '_set_weight', ); This might be useful if weight is calculated based on other methods. For example, every time the C method is called, we might adjust weight. This lets us hide the implementation details of weight changes, but still provide the weight value to users of the class. Some people might prefer to have distinct methods for reading and writing. In I, Damian Conway recommends that reader methods start with "get_" and writer methods start with "set_". We can do exactly that by providing names for both the C and C methods: has 'weight' => ( is => 'rw', reader => 'get_weight', writer => 'set_weight', ); If you're thinking that doing this over and over would be insanely tedious, you're right! Fortunately, Moose provides a powerful extension system that lets you override the default naming conventions. See L for more details. =head2 Predicate and clearer methods Moose allows you to explicitly distinguish between a false or undefined attribute value and an attribute which has not been set. If you want to access this information, you must define clearer and predicate methods for an attribute. A predicate method tells you whether or not a given attribute is currently set. Note that an attribute can be explicitly set to C or some other false value, but the predicate will return true. The clearer method unsets the attribute. This is I the same as setting the value to C, but you can only distinguish between them if you define a predicate method! Here's some code to illustrate the relationship between an accessor, predicate, and clearer method. package Person; use Moose; has 'ssn' => ( is => 'rw', clearer => 'clear_ssn', predicate => 'has_ssn', ); ... my $person = Person->new(); $person->has_ssn; # false $person->ssn(undef); $person->ssn; # returns undef $person->has_ssn; # true $person->clear_ssn; $person->ssn; # returns undef $person->has_ssn; # false $person->ssn('123-45-6789'); $person->ssn; # returns '123-45-6789' $person->has_ssn; # true my $person2 = Person->new( ssn => '111-22-3333'); $person2->has_ssn; # true By default, Moose does not make a predicate or clearer for you. You must explicitly provide names for them, and then Moose will create the methods for you. =head2 Required or not? By default, all attributes are optional, and do not need to be provided at object construction time. If you want to make an attribute required, simply set the C option to true: has 'name' => ( is => 'ro', required => 1, ); There are a couple caveats worth mentioning in regards to what "required" actually means. Basically, all it says is that this attribute (C) must be provided to the constructor, or be lazy with either a default or a builder. It does not say anything about its value, so it could be C. If you define a clearer method on a required attribute, the clearer I work, so even a required attribute can be unset after object construction. This means that if you do make an attribute required, providing a clearer doesn't make much sense. In some cases, it might be handy to have a I C and C for a required attribute. =head2 Default and builder methods Attributes can have default values, and Moose provides two ways to specify that default. In the simplest form, you simply provide a non-reference scalar value for the C option: has 'size' => ( is => 'ro', default => 'medium', predicate => 'has_size', ); If the size attribute is not provided to the constructor, then it ends up being set to C: my $person = Person->new(); $person->size; # medium $person->has_size; # true You can also provide a subroutine reference for C. This reference will be called as a method on the object. has 'size' => ( is => 'ro', default => sub { ( 'small', 'medium', 'large' )[ int( rand 3 ) ] }, predicate => 'has_size', ); This is a trivial example, but it illustrates the point that the subroutine will be called for every new object created. When you provide a C subroutine reference, it is called as a method on the object, with no additional parameters: has 'size' => ( is => 'ro', default => sub { my $self = shift; return $self->height > 200 ? 'large' : 'average'; }, ); When the C is called during object construction, it may be called before other attributes have been set. If your default is dependent on other parts of the object's state, you can make the attribute C. Laziness is covered in the next section. If you want to use a reference of any sort as the default value, you must return it from a subroutine. has 'mapping' => ( is => 'ro', default => sub { {} }, ); This is necessary because otherwise Perl would instantiate the reference exactly once, and it would be shared by all objects: has 'mapping' => ( is => 'ro', default => {}, # wrong! ); Moose will throw an error if you pass a bare non-subroutine reference as the default. If Moose allowed this then the default mapping attribute could easily end up shared across many objects. Instead, wrap it in a subroutine reference as we saw above. This is a bit awkward, but it's just the way Perl works. As an alternative to using a subroutine reference, you can supply a C method for your attribute: has 'size' => ( is => 'ro', builder => '_build_size', predicate => 'has_size', ); sub _build_size { return ( 'small', 'medium', 'large' )[ int( rand 3 ) ]; } This has several advantages. First, it moves a chunk of code to its own named method, which improves readability and code organization. Second, because this is a I method, it can be subclassed or provided by a role. We strongly recommend that you use a C instead of a C for anything beyond the most trivial default. A C, just like a C, is called as a method on the object with no additional parameters. =head3 Builders allow subclassing Because the C is called I, it goes through Perl's method resolution. This means that builder methods are both inheritable and overridable. If we subclass our C class, we can override C<_build_size>: package Lilliputian; use Moose; extends 'Person'; sub _build_size { return 'small' } =head3 Builders work well with roles Because builders are called by name, they work well with roles. For example, a role could provide an attribute but require that the consuming class provide the C: package HasSize; use Moose::Role; requires '_build_size'; has 'size' => ( is => 'ro', lazy => 1, builder => '_build_size', ); package Lilliputian; use Moose; with 'HasSize'; sub _build_size { return 'small' } Roles are covered in L. =head2 Laziness Moose lets you defer attribute population by making an attribute C: has 'size' => ( is => 'ro', lazy => 1, builder => '_build_size', ); When C is true, the default is not generated until the reader method is called, rather than at object construction time. There are several reasons you might choose to do this. First, if the default value for this attribute depends on some other attributes, then the attribute I be C. During object construction, defaults are not generated in a predictable order, so you cannot count on some other attribute being populated when generating a default. Second, there's often no reason to calculate a default before it's needed. Making an attribute C lets you defer the cost until the attribute is needed. If the attribute is I needed, you save some CPU time. We recommend that you make any attribute with a builder or non-trivial default C as a matter of course. =head3 Lazy defaults and C<$_> Please note that a lazy default or builder can be called anywhere, even inside a C or C. This means that if your default sub or builder changes C<$_>, something weird could happen. You can prevent this by adding C inside your default or builder. =head2 Constructor parameters (C) By default, each attribute can be passed by name to the class's constructor. On occasion, you may want to use a different name for the constructor parameter. You may also want to make an attribute unsettable via the constructor. You can do either of these things with the C option: has 'bigness' => ( is => 'ro', init_arg => 'size', ); Now we have an attribute named "bigness", but we pass C to the constructor. Even more useful is the ability to disable setting an attribute via the constructor. This is particularly handy for private attributes: has '_genetic_code' => ( is => 'ro', lazy => 1, builder => '_build_genetic_code', init_arg => undef, ); By setting the C to C, we make it impossible to set this attribute when creating a new object. =head2 Weak references Moose has built-in support for weak references. If you set the C option to a true value, then it will call C whenever the attribute is set: has 'parent' => ( is => 'rw', weak_ref => 1, ); $node->parent($parent_node); This is very useful when you're building objects that may contain circular references. When the object in a weak references goes out of scope, the attribute's value will become C "behind the scenes". This is done by the Perl interpreter directly, so Moose does not see this change. This means that triggers don't fire, coercions aren't applied, etc. The attribute is not cleared, so a predicate method for that attribute will still return true. Similarly, when the attribute is next accessed, a default value will not be generated. =head2 Triggers A C is a subroutine that is called whenever the attribute is set: has 'size' => ( is => 'rw', trigger => \&_size_set, ); sub _size_set { my ( $self, $size, $old_size ) = @_; my $msg = $self->name; if ( @_ > 2 ) { $msg .= " - old size was $old_size"; } $msg .= " - size is now $size"; warn $msg; } The trigger is called I an attribute's value is set. It is called as a method on the object, and receives the new and old values as its arguments. If the attribute had not previously been set at all, then only the new value is passed. This lets you distinguish between the case where the attribute had no value versus when the old value was C. This differs from an C method modifier in two ways. First, a trigger is only called when the attribute is set, as opposed to whenever the accessor method is called (for reading or writing). Second, it is also called when an attribute's value is passed to the constructor. However, triggers are I called when an attribute is populated from a C or C. =head2 Attribute types Attributes can be restricted to only accept certain types: has 'first_name' => ( is => 'ro', isa => 'Str', ); This says that the C attribute must be a string. Moose also provides a shortcut for specifying that an attribute only accepts objects that do a certain role: has 'weapon' => ( is => 'rw', does => 'MyApp::Weapon', ); See the L documentation for a complete discussion of Moose's type system. =head2 Delegation An attribute can define methods which simply delegate to its value: has 'hair_color' => ( is => 'ro', isa => 'Graphics::Color::RGB', handles => { hair_color_hex => 'as_hex_string' }, ); This adds a new method, C. When someone calls C, internally, the object just calls C<< $self->hair_color->as_hex_string >>. See L for documentation on how to set up delegation methods. =head2 Attribute traits and metaclasses One of Moose's best features is that it can be extended in all sorts of ways through the use of metaclass traits and custom metaclasses. You can apply one or more traits to an attribute: use MooseX::MetaDescription; has 'size' => ( is => 'ro', traits => ['MooseX::MetaDescription::Meta::Trait'], description => { html_widget => 'text_input', serialize_as => 'element', }, ); The advantage of traits is that you can mix more than one of them together easily (in fact, a trait is just a role under the hood). There are a number of MooseX modules on CPAN which provide useful attribute metaclasses and traits. See L for some examples. You can also write your own metaclasses and traits. See the "Meta" and "Extending" recipes in L for examples. =head2 Native Delegations Native delegations allow you to delegate to standard Perl data structures as if they were objects. For example, we can pretend that an array reference has methods like C, C, C, C, and more. has 'options' => ( traits => ['Array'], is => 'ro', isa => 'ArrayRef[Str]', default => sub { [] }, handles => { all_options => 'elements', add_option => 'push', map_options => 'map', option_count => 'count', sorted_options => 'sort', }, ); See L for more details. =head1 ATTRIBUTE INHERITANCE By default, a child inherits all of its parent class(es)' attributes as-is. However, you can change most aspects of the inherited attribute in the child class. You cannot change any of its associated method names (reader, writer, predicate, etc). To override an attribute, you simply prepend its name with a plus sign (C<+>): package LazyPerson; use Moose; extends 'Person'; has '+first_name' => ( lazy => 1, default => 'Bill', ); Now the C attribute in C is lazy, and defaults to C<'Bill'>. We recommend that you exercise caution when changing the type (C) of an inherited attribute. =head1 MULTIPLE ATTRIBUTE SHORTCUTS If you have a number of attributes that differ only by name, you can declare them all at once: package Point; use Moose; has [ 'x', 'y' ] => ( is => 'ro', isa => 'Int' ); Also, because C is just a function call, you can call it in a loop: for my $name ( qw( x y ) ) { my $builder = '_build_' . $name; has $name => ( is => 'ro', isa => 'Int', builder => $builder ); } =head1 MORE ON ATTRIBUTES Moose attributes are a big topic, and this document glosses over a few aspects. We recommend that you read the L and L documents to get a more complete understanding of attribute features. =head1 A FEW MORE OPTIONS Moose has lots of attribute options. The ones listed below are superseded by some more modern features, but are covered for the sake of completeness. =head2 The C option You can provide a piece of documentation as a string for an attribute: has 'first_name' => ( is => 'rw', documentation => q{The person's first (personal) name}, ); Moose does absolutely nothing with this information other than store it. =head2 The C option If your attribute is an array reference or hash reference, the C option will make Moose dereference the value when it is returned from the reader method I: my %map = $object->mapping; This option only works if your attribute is explicitly typed as an C or C. When the reader is called in I context, the reference itself is returned. However, we recommend that you use L traits for these types of attributes, which gives you much more control over how they are accessed and manipulated. See also L. =head2 Initializer Moose provides an attribute option called C. This is called when the attribute's value is being set in the constructor, and lets you change the value before it is set. =head1 AUTHOR Moose is maintained by the Moose Cabal, along with the help of many contributors. See L and L for details. =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2013 by Infinity Interactive, Inc.. This is free software; you can redistribute it and/or modify it under the same terms as the Perl 5 programming language system itself. =cut Delegation.pod100644000767000024 1562312200352344 20207 0ustar00etherstaff000000000000Moose-2.1005/lib/Moose/Manualpackage Moose::Manual::Delegation; # ABSTRACT: Attribute delegation __END__ =pod =head1 NAME Moose::Manual::Delegation - Attribute delegation =head1 VERSION version 2.1005 =head1 WHAT IS DELEGATION? Delegation is a feature that lets you create "proxy" methods that do nothing more than call some other method on an attribute. This lets you simplify a complex set of "has-a" relationships and present a single unified API from one class. With delegation, consumers of a class don't need to know about all the objects it contains, reducing the amount of API they need to learn. Delegations are defined as a mapping between one or more methods provided by the "real" class (the delegatee), and a set of corresponding methods in the delegating class. The delegating class can re-use the method names provided by the delegatee or provide its own names. Delegation is also a great way to wrap an existing class, especially a non-Moose class or one that is somehow hard (or impossible) to subclass. =head1 DEFINING A MAPPING Moose offers a number of options for defining a delegation's mapping, ranging from simple to complex. The simplest form is to simply specify a list of methods: package Website; use Moose; has 'uri' => ( is => 'ro', isa => 'URI', handles => [qw( host path )], ); Using an arrayref tells Moose to create methods in your class that match the method names in the delegated class. With this definition, we can call C<< $website->host >> and it "just works". Under the hood, Moose will call C<< $website->uri->host >> for you. Note that C<$website> is I automatically passed to the C method; the invocant is C<< $website->uri >>. We can also define a mapping as a hash reference. This allows you to rename methods as part of the mapping: package Website; use Moose; has 'uri' => ( is => 'ro', isa => 'URI', handles => { hostname => 'host', path => 'path', }, ); Using a hash tells Moose to create method names (specified on the left) which invoke the delegated class methods (specified on the right). In this example, we've created a C<< $website->hostname >> method, rather than simply using C's name, C in the Website class. These two mapping forms are the ones you will use most often. The remaining methods are a bit more complex. has 'uri' => ( is => 'ro', isa => 'URI', handles => qr/^(?:host|path|query.*)/, ); This is similar to the array version, except it uses the regex to match against all the methods provided by the delegatee. In order for this to work, you must provide an C parameter for the attribute, and it must be a class. Moose uses this to introspect the delegatee class and determine what methods it provides. You can use a role name as the value of C: has 'uri' => ( is => 'ro', isa => 'URI', handles => 'HasURI', ); Moose will introspect the role to determine what methods it provides and create a name-for-name mapping for each of those methods. Finally, you can provide a sub reference to I a mapping that behaves like the hash example above. You probably won't need this version often (if ever). See the L docs for more details on exactly how this works. =head1 NATIVE DELEGATION Native delegations allow you to delegate to standard Perl data structures as if they were objects. has 'queue' => ( traits => ['Array'], isa => 'ArrayRef[Item]', default => sub { [ ] }, handles => { add_item => 'push', next_item => 'shift', }, ) The C trait in the C parameter tells Moose that you would like to use the set of Array helpers. Moose will then create C and C methods that "just work". Behind the scenes C is something like sub add_item { my ($self, @items) = @_; for my $item (@items) { $Item_TC->validate($item); } push @{ $self->queue }, @items; } Moose includes the following traits for native delegation. As mentioned above, each trait provides a number of methods which are summarized below. For more information about each of these provided methods see the documentation for that specific trait. =over 4 =item * L The following methods are provided by the native Array trait: count, is_empty, elements, get, pop, push, shift, unshift, splice, first, first_index, grep, map, reduce, sort, sort_in_place, shuffle, uniq, join, set, delete, insert, clear, accessor, natatime, shallow_clone =item * L The following methods are provided by the native Bool trait: set, unset, toggle, not =item * L The following methods are provided by the native Code trait: execute, execute_method =item * L The following methods are provided by the native Counter trait: set, inc, dec, reset =item * L The following methods are provided by the native Hash trait: get, set, delete, keys, exists, defined, values, kv, elements, clear, count, is_empty, accessor, shallow_clone =item * L The following methods are provided by the native Number trait: add, sub, mul, div, mod, abs =item * L The following methods are provided by the native String trait: inc, append, prepend, replace, match, chop, chomp, clear, length, substr =back =head1 CURRYING Currying allows you to create a method with some pre-set parameters. You can create a curried delegation method: package Spider; use Moose; has request => ( is => 'ro' isa => 'HTTP::Request', handles => { set_user_agent => [ header => 'UserAgent' ], }, ) With this definition, calling C<< $spider->set_user_agent('MyClient') >> will call C<< $spider->request->header('UserAgent', 'MyClient') >> behind the scenes. Note that with currying, the currying always starts with the first parameter to a method (C<$_[0]>). Any arguments you pass to the delegation come after the curried arguments. =head1 MISSING ATTRIBUTES It is perfectly valid to delegate methods to an attribute which is not required or can be undefined. When a delegated method is called, Moose will throw a runtime error if the attribute does not contain an object. =head1 AUTHOR Moose is maintained by the Moose Cabal, along with the help of many contributors. See L and L for details. =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2013 by Infinity Interactive, Inc.. This is free software; you can redistribute it and/or modify it under the same terms as the Perl 5 programming language system itself. =cut accessor_context.t100644000767000024 356312200352344 20527 0ustar00etherstaff000000000000Moose-2.1005/t/attributes#!/usr/bin/perl use strict; use warnings; use Test::More; use Test::Fatal; is( exception { package My::Class; use Moose; has s_rw => ( is => 'rw', ); has s_ro => ( is => 'ro', ); has a_rw => ( is => 'rw', isa => 'ArrayRef', auto_deref => 1, ); has a_ro => ( is => 'ro', isa => 'ArrayRef', auto_deref => 1, ); has h_rw => ( is => 'rw', isa => 'HashRef', auto_deref => 1, ); has h_ro => ( is => 'ro', isa => 'HashRef', auto_deref => 1, ); }, undef, 'class definition' ); is( exception { my $o = My::Class->new(); is_deeply [scalar $o->s_rw], [undef], 'uninitialized scalar attribute/rw in scalar context'; is_deeply [$o->s_rw], [undef], 'uninitialized scalar attribute/rw in list context'; is_deeply [scalar $o->s_ro], [undef], 'uninitialized scalar attribute/ro in scalar context'; is_deeply [$o->s_ro], [undef], 'uninitialized scalar attribute/ro in list context'; is_deeply [scalar $o->a_rw], [undef], 'uninitialized ArrayRef attribute/rw in scalar context'; is_deeply [$o->a_rw], [], 'uninitialized ArrayRef attribute/rw in list context'; is_deeply [scalar $o->a_ro], [undef], 'uninitialized ArrayRef attribute/ro in scalar context'; is_deeply [$o->a_ro], [], 'uninitialized ArrayRef attribute/ro in list context'; is_deeply [scalar $o->h_rw], [undef], 'uninitialized HashRef attribute/rw in scalar context'; is_deeply [$o->h_rw], [], 'uninitialized HashRef attribute/rw in list context'; is_deeply [scalar $o->h_ro], [undef], 'uninitialized HashRef attribute/ro in scalar context'; is_deeply [$o->h_ro], [], 'uninitialized HashRef attribute/ro in list context'; }, undef, 'testing' ); done_testing; attribute_traits.t100644000767000024 303712200352344 20546 0ustar00etherstaff000000000000Moose-2.1005/t/attributes#!/usr/bin/perl use strict; use warnings; use Test::More; use Test::Moose; { package My::Attribute::Trait; use Moose::Role; has 'alias_to' => (is => 'ro', isa => 'Str'); has foo => ( is => "ro", default => "blah" ); after 'install_accessors' => sub { my $self = shift; $self->associated_class->add_method( $self->alias_to, $self->get_read_method_ref ); }; } { package My::Class; use Moose; has 'bar' => ( traits => [qw/My::Attribute::Trait/], is => 'ro', isa => 'Int', alias_to => 'baz', ); has 'gorch' => ( is => 'ro', isa => 'Int', default => sub { 10 } ); } my $c = My::Class->new(bar => 100); isa_ok($c, 'My::Class'); is($c->bar, 100, '... got the right value for bar'); is($c->gorch, 10, '... got the right value for gorch'); can_ok($c, 'baz'); is($c->baz, 100, '... got the right value for baz'); my $bar_attr = $c->meta->get_attribute('bar'); does_ok($bar_attr, 'My::Attribute::Trait'); ok($bar_attr->has_applied_traits, '... got the applied traits'); is_deeply($bar_attr->applied_traits, [qw/My::Attribute::Trait/], '... got the applied traits'); is($bar_attr->foo, "blah", "attr initialized"); my $gorch_attr = $c->meta->get_attribute('gorch'); ok(!$gorch_attr->does('My::Attribute::Trait'), '... gorch doesnt do the trait'); ok(!$gorch_attr->has_applied_traits, '... no traits applied'); is($gorch_attr->applied_traits, undef, '... no traits applied'); done_testing; chained_coercion.t100644000767000024 153212200352344 20427 0ustar00etherstaff000000000000Moose-2.1005/t/attributes#!/usr/bin/perl use strict; use warnings; use Test::More; { package Baz; use Moose; use Moose::Util::TypeConstraints; coerce 'Baz' => from 'HashRef' => via { Baz->new($_) }; has 'hello' => ( is => 'ro', isa => 'Str', ); package Bar; use Moose; use Moose::Util::TypeConstraints; coerce 'Bar' => from 'HashRef' => via { Bar->new($_) }; has 'baz' => ( is => 'ro', isa => 'Baz', coerce => 1 ); package Foo; use Moose; has 'bar' => ( is => 'ro', isa => 'Bar', coerce => 1, ); } my $foo = Foo->new(bar => { baz => { hello => 'World' } }); isa_ok($foo, 'Foo'); isa_ok($foo->bar, 'Bar'); isa_ok($foo->bar->baz, 'Baz'); is($foo->bar->baz->hello, 'World', '... this all worked fine'); done_testing; numeric_defaults.t100644000767000024 565712200352344 20520 0ustar00etherstaff000000000000Moose-2.1005/t/attributes#!/usr/bin/env perl use strict; use warnings; use Test::More; use Test::Moose; use B; { package Foo; use Moose; has foo => (is => 'ro', default => 100); sub bar { 100 } } with_immutable { my $foo = Foo->new; for my $meth (qw(foo bar)) { my $val = $foo->$meth; my $b = B::svref_2object(\$val); my $flags = $b->FLAGS; ok($flags & B::SVf_IOK || $flags & B::SVp_IOK, "it's an int"); ok(!($flags & B::SVf_POK), "not a string"); } } 'Foo'; { package Bar; use Moose; has foo => (is => 'ro', lazy => 1, default => 100); sub bar { 100 } } with_immutable { my $bar = Bar->new; for my $meth (qw(foo bar)) { my $val = $bar->$meth; my $b = B::svref_2object(\$val); my $flags = $b->FLAGS; ok($flags & B::SVf_IOK || $flags & B::SVp_IOK, "it's an int"); ok(!($flags & B::SVf_POK), "not a string"); } } 'Bar'; { package Baz; use Moose; has foo => (is => 'ro', isa => 'Int', lazy => 1, default => 100); sub bar { 100 } } with_immutable { my $baz = Baz->new; for my $meth (qw(foo bar)) { my $val = $baz->$meth; my $b = B::svref_2object(\$val); my $flags = $b->FLAGS; ok($flags & B::SVf_IOK || $flags & B::SVp_IOK, "it's an int"); ok(!($flags & B::SVf_POK), "not a string"); } } 'Baz'; { package Foo2; use Moose; has foo => (is => 'ro', default => 10.5); sub bar { 10.5 } } with_immutable { my $foo2 = Foo2->new; for my $meth (qw(foo bar)) { my $val = $foo2->$meth; my $b = B::svref_2object(\$val); my $flags = $b->FLAGS; ok($flags & B::SVf_NOK || $flags & B::SVp_NOK, "it's a num"); ok(!($flags & B::SVf_POK), "not a string"); } } 'Foo2'; { package Bar2; use Moose; has foo => (is => 'ro', lazy => 1, default => 10.5); sub bar { 10.5 } } with_immutable { my $bar2 = Bar2->new; for my $meth (qw(foo bar)) { my $val = $bar2->$meth; my $b = B::svref_2object(\$val); my $flags = $b->FLAGS; ok($flags & B::SVf_NOK || $flags & B::SVp_NOK, "it's a num"); ok(!($flags & B::SVf_POK), "not a string"); } } 'Bar2'; { package Baz2; use Moose; has foo => (is => 'ro', isa => 'Num', lazy => 1, default => 10.5); sub bar { 10.5 } } with_immutable { my $baz2 = Baz2->new; for my $meth (qw(foo bar)) { my $val = $baz2->$meth; my $b = B::svref_2object(\$val); my $flags = $b->FLAGS; ok($flags & B::SVf_NOK || $flags & B::SVp_NOK, "it's a num"); # it's making sure that the Num value doesn't get converted to a string for regex matching # this is the reason for using a temporary variable, $val for regex matching, # instead of $_[1] in Num implementation in lib/Moose/Util/TypeConstraints/Builtins.pm ok(!($flags & B::SVf_POK), "not a string"); } } 'Baz2'; done_testing; require_superclasses.t100644000767000024 215012200352344 20476 0ustar00etherstaff000000000000Moose-2.1005/t/basics#!/usr/bin/perl use strict; use warnings; use lib 't/lib', 'lib'; use Test::More; use Test::Fatal; { package Bar; use Moose; ::is( ::exception { extends 'Foo' }, undef, 'loaded Foo superclass correctly' ); } { package Baz; use Moose; ::is( ::exception { extends 'Bar' }, undef, 'loaded (inline) Bar superclass correctly' ); } { package Foo::Bar; use Moose; ::is( ::exception { extends 'Foo', 'Bar' }, undef, 'loaded Foo and (inline) Bar superclass correctly' ); } { package Bling; use Moose; ::like( ::exception { extends 'No::Class' }, qr{Can't locate No/Class\.pm in \@INC}, 'correct error when superclass could not be found' ); } { package Affe; our $VERSION = 23; } { package Tiger; use Moose; ::is( ::exception { extends 'Foo', Affe => { -version => 13 } }, undef, 'extends with version requirement' ); } { package Birne; use Moose; ::like( ::exception { extends 'Foo', Affe => { -version => 42 } }, qr/Affe version 42 required--this is only version 23/, 'extends with unsatisfied version requirement' ); } done_testing; immutable_n_default_x2.t100644000767000024 134112200352344 20334 0ustar00etherstaff000000000000Moose-2.1005/t/bugs#!/usr/bin/perl use strict; use warnings; use Test::More; { package Foo; use Moose; our $foo_default_called = 0; has foo => ( is => 'rw', isa => 'Str', default => sub { $foo_default_called++; 'foo' }, ); our $bar_default_called = 0; has bar => ( is => 'rw', isa => 'Str', lazy => 1, default => sub { $bar_default_called++; 'bar' }, ); __PACKAGE__->meta->make_immutable; } my $foo = Foo->new(); is($Foo::foo_default_called, 1, "foo default was only called once during constructor"); $foo->bar(); is($Foo::bar_default_called, 1, "bar default was only called once when lazy attribute is accessed"); done_testing; anon_class_create_init.t100644000767000024 766212200352344 20423 0ustar00etherstaff000000000000Moose-2.1005/t/cmopuse strict; use warnings; use Test::More; use Test::Fatal; use Class::MOP; { package MyMeta; use base 'Class::MOP::Class'; sub initialize { my $class = shift; my ( $package, %options ) = @_; ::cmp_ok( $options{foo}, 'eq', 'this', 'option passed to initialize() on create_anon_class()' ); return $class->SUPER::initialize( @_ ); } } { my $anon = MyMeta->create_anon_class( foo => 'this' ); isa_ok( $anon, 'MyMeta' ); } my $instance; { my $meta = Class::MOP::Class->create_anon_class; $instance = $meta->new_object; } { my $meta = Class::MOP::class_of($instance); Scalar::Util::weaken($meta); ok($meta, "anon class is kept alive by existing instances"); undef $instance; ok(!$meta, "anon class is collected once instances go away"); } { my $meta = Class::MOP::Class->create_anon_class; $meta->make_immutable; $instance = $meta->name->new; } { my $meta = Class::MOP::class_of($instance); Scalar::Util::weaken($meta); ok($meta, "anon class is kept alive by existing instances (immutable)"); undef $instance; ok(!$meta, "anon class is collected once instances go away (immutable)"); } { $instance = Class::MOP::Class->create('Foo')->new_object; my $meta = Class::MOP::Class->create_anon_class(superclasses => ['Foo']); $meta->rebless_instance($instance); } { my $meta = Class::MOP::class_of($instance); Scalar::Util::weaken($meta); ok($meta, "anon class is kept alive by existing instances"); undef $instance; ok(!$meta, "anon class is collected once instances go away"); } { { my $meta = Class::MOP::Class->create_anon_class; { my $submeta = Class::MOP::Class->create_anon_class( superclasses => [$meta->name] ); $instance = $submeta->new_object; } { my $submeta = Class::MOP::class_of($instance); Scalar::Util::weaken($submeta); ok($submeta, "anon class is kept alive by existing instances"); $meta->rebless_instance_back($instance); ok(!$submeta, "reblessing away loses the metaclass"); } } my $meta = Class::MOP::class_of($instance); Scalar::Util::weaken($meta); ok($meta, "anon class is kept alive by existing instances"); } { my $submeta = Class::MOP::Class->create_anon_class( superclasses => [Class::MOP::Class->create_anon_class->name], ); my @superclasses = $submeta->superclasses; ok(Class::MOP::class_of($superclasses[0]), "superclasses are kept alive by their subclasses"); } { my $meta_name; { my $meta = Class::MOP::Class->create_anon_class( superclasses => ['Class::MOP::Class'], ); $meta_name = $meta->name; ok(Class::MOP::metaclass_is_weak($meta_name), "default is for anon metaclasses to be weakened"); } ok(!Class::MOP::class_of($meta_name), "and weak metaclasses go away when all refs do"); { my $meta = Class::MOP::Class->create_anon_class( superclasses => ['Class::MOP::Class'], weaken => 0, ); $meta_name = $meta->name; ok(!Class::MOP::metaclass_is_weak($meta_name), "anon classes can be told not to weaken"); } ok(Class::MOP::class_of($meta_name), "metaclass still exists"); { my $bar_meta; is( exception { $bar_meta = $meta_name->initialize('Bar'); }, undef, "we can use the name on its own" ); isa_ok($bar_meta, $meta_name); } } { my $meta = Class::MOP::Class->create( 'Baz', weaken => 1, ); $instance = $meta->new_object; } { my $meta = Class::MOP::class_of($instance); Scalar::Util::weaken($meta); ok($meta, "weak class is kept alive by existing instances"); undef $instance; ok(!$meta, "weak class is collected once instances go away"); } done_testing; ArrayBasedStorage_test.t100644000767000024 1262012200352344 20344 0ustar00etherstaff000000000000Moose-2.1005/t/cmopuse strict; use warnings; use Test::More; use File::Spec; use Scalar::Util 'reftype'; use Class::MOP; BEGIN { require_ok(File::Spec->catfile('examples', 'ArrayBasedStorage.pod')); } { package Foo; use strict; use warnings; use metaclass ( 'instance_metaclass' => 'ArrayBasedStorage::Instance', ); Foo->meta->add_attribute('foo' => ( accessor => 'foo', clearer => 'clear_foo', predicate => 'has_foo', )); Foo->meta->add_attribute('bar' => ( reader => 'get_bar', writer => 'set_bar', default => 'FOO is BAR' )); sub new { my $class = shift; $class->meta->new_object(@_); } package Bar; use metaclass ( 'instance_metaclass' => 'ArrayBasedStorage::Instance', ); use strict; use warnings; use base 'Foo'; Bar->meta->add_attribute('baz' => ( accessor => 'baz', predicate => 'has_baz', )); package Baz; use metaclass ( 'instance_metaclass' => 'ArrayBasedStorage::Instance', ); use strict; use warnings; use metaclass ( 'instance_metaclass' => 'ArrayBasedStorage::Instance', ); Baz->meta->add_attribute('bling' => ( accessor => 'bling', default => 'Baz::bling' )); package Bar::Baz; use metaclass ( 'instance_metaclass' => 'ArrayBasedStorage::Instance', ); use strict; use warnings; use base 'Bar', 'Baz'; } my $foo = Foo->new(); isa_ok($foo, 'Foo'); is(reftype($foo), 'ARRAY', '... Foo is made with ARRAY'); can_ok($foo, 'foo'); can_ok($foo, 'has_foo'); can_ok($foo, 'get_bar'); can_ok($foo, 'set_bar'); can_ok($foo, 'clear_foo'); ok(!$foo->has_foo, '... Foo::foo is not defined yet'); is($foo->foo(), undef, '... Foo::foo is not defined yet'); is($foo->get_bar(), 'FOO is BAR', '... Foo::bar has been initialized'); $foo->foo('This is Foo'); ok($foo->has_foo, '... Foo::foo is defined now'); is($foo->foo(), 'This is Foo', '... Foo::foo == "This is Foo"'); $foo->clear_foo; ok(!$foo->has_foo, '... Foo::foo is not defined anymore'); is($foo->foo(), undef, '... Foo::foo is not defined anymore'); $foo->set_bar(42); is($foo->get_bar(), 42, '... Foo::bar == 42'); my $foo2 = Foo->new(); isa_ok($foo2, 'Foo'); is(reftype($foo2), 'ARRAY', '... Foo is made with ARRAY'); ok(!$foo2->has_foo, '... Foo2::foo is not defined yet'); is($foo2->foo(), undef, '... Foo2::foo is not defined yet'); is($foo2->get_bar(), 'FOO is BAR', '... Foo2::bar has been initialized'); $foo2->set_bar('DONT PANIC'); is($foo2->get_bar(), 'DONT PANIC', '... Foo2::bar == DONT PANIC'); is($foo->get_bar(), 42, '... Foo::bar == 42'); # now Bar ... my $bar = Bar->new(); isa_ok($bar, 'Bar'); isa_ok($bar, 'Foo'); is(reftype($bar), 'ARRAY', '... Bar is made with ARRAY'); can_ok($bar, 'foo'); can_ok($bar, 'has_foo'); can_ok($bar, 'get_bar'); can_ok($bar, 'set_bar'); can_ok($bar, 'baz'); can_ok($bar, 'has_baz'); ok(!$bar->has_foo, '... Bar::foo is not defined yet'); is($bar->foo(), undef, '... Bar::foo is not defined yet'); is($bar->get_bar(), 'FOO is BAR', '... Bar::bar has been initialized'); ok(!$bar->has_baz, '... Bar::baz is not defined yet'); is($bar->baz(), undef, '... Bar::baz is not defined yet'); $bar->foo('This is Bar::foo'); ok($bar->has_foo, '... Bar::foo is defined now'); is($bar->foo(), 'This is Bar::foo', '... Bar::foo == "This is Bar"'); is($bar->get_bar(), 'FOO is BAR', '... Bar::bar has been initialized'); $bar->baz('This is Bar::baz'); ok($bar->has_baz, '... Bar::baz is defined now'); is($bar->baz(), 'This is Bar::baz', '... Bar::foo == "This is Bar"'); is($bar->foo(), 'This is Bar::foo', '... Bar::foo == "This is Bar"'); is($bar->get_bar(), 'FOO is BAR', '... Bar::bar has been initialized'); # now Baz ... my $baz = Bar::Baz->new(); isa_ok($baz, 'Bar::Baz'); isa_ok($baz, 'Bar'); isa_ok($baz, 'Foo'); isa_ok($baz, 'Baz'); is(reftype($baz), 'ARRAY', '... Bar::Baz is made with ARRAY'); can_ok($baz, 'foo'); can_ok($baz, 'has_foo'); can_ok($baz, 'get_bar'); can_ok($baz, 'set_bar'); can_ok($baz, 'baz'); can_ok($baz, 'has_baz'); can_ok($baz, 'bling'); is($baz->get_bar(), 'FOO is BAR', '... Bar::Baz::bar has been initialized'); is($baz->bling(), 'Baz::bling', '... Bar::Baz::bling has been initialized'); ok(!$baz->has_foo, '... Bar::Baz::foo is not defined yet'); is($baz->foo(), undef, '... Bar::Baz::foo is not defined yet'); ok(!$baz->has_baz, '... Bar::Baz::baz is not defined yet'); is($baz->baz(), undef, '... Bar::Baz::baz is not defined yet'); $baz->foo('This is Bar::Baz::foo'); ok($baz->has_foo, '... Bar::Baz::foo is defined now'); is($baz->foo(), 'This is Bar::Baz::foo', '... Bar::Baz::foo == "This is Bar"'); is($baz->get_bar(), 'FOO is BAR', '... Bar::Baz::bar has been initialized'); is($baz->bling(), 'Baz::bling', '... Bar::Baz::bling has been initialized'); $baz->baz('This is Bar::Baz::baz'); ok($baz->has_baz, '... Bar::Baz::baz is defined now'); is($baz->baz(), 'This is Bar::Baz::baz', '... Bar::Baz::foo == "This is Bar"'); is($baz->foo(), 'This is Bar::Baz::foo', '... Bar::Baz::foo == "This is Bar"'); is($baz->get_bar(), 'FOO is BAR', '... Bar::Baz::bar has been initialized'); is($baz->bling(), 'Baz::bling', '... Bar::Baz::bling has been initialized'); Foo->meta->add_attribute( forgotten => is => "rw" ); my $new_baz = Bar::Baz->new; cmp_ok( scalar(@$new_baz), ">", scalar(@$baz), "additional slot due to refreshed meta instance" ); done_testing; Class_C3_compatibility.t100644000767000024 272712200352344 20255 0ustar00etherstaff000000000000Moose-2.1005/t/cmopuse strict; use warnings; use Test::More; =pod This tests that Class::MOP works correctly with Class::C3 and it's somewhat insane approach to method resolution. =cut use Class::MOP; { package Diamond_A; use mro 'c3'; use metaclass; # everyone will just inherit this now :) sub hello { 'Diamond_A::hello' } } { package Diamond_B; use mro 'c3'; use base 'Diamond_A'; } { package Diamond_C; use mro 'c3'; use base 'Diamond_A'; sub hello { 'Diamond_C::hello' } } { package Diamond_D; use mro 'c3'; use base ('Diamond_B', 'Diamond_C'); } # we have to manually initialize # Class::C3 since we potentially # skip this test if it is not present Class::C3::initialize(); is_deeply( # [ Class::C3::calculateMRO('Diamond_D') ], [ Diamond_D->meta->class_precedence_list ], [ qw(Diamond_D Diamond_B Diamond_C Diamond_A) ], '... got the right MRO for Diamond_D'); ok(Diamond_A->meta->has_method('hello'), '... A has a method hello'); ok(!Diamond_B->meta->has_method('hello'), '... B does not have a method hello'); ok(Diamond_C->meta->has_method('hello'), '... C has a method hello'); ok(!Diamond_D->meta->has_method('hello'), '... D does not have a method hello'); SKIP: { skip "C3 does not make aliases on 5.9.5+", 2 if $] > 5.009_004; ok(defined &Diamond_B::hello, '... B does have an alias to the method hello'); ok(defined &Diamond_D::hello, '... D does have an alias to the method hello'); } done_testing; immutable_custom_trait.t100644000767000024 252512200352344 20502 0ustar00etherstaff000000000000Moose-2.1005/t/cmopuse strict; use warnings; use Test::More; use Test::Fatal; use Class::MOP; { package My::Meta; use strict; use warnings; use base 'Class::MOP::Class'; sub initialize { shift->SUPER::initialize( @_, immutable_trait => 'My::Meta::Class::Immutable::Trait', ); } } { package My::Meta::Class::Immutable::Trait; use MRO::Compat; use base 'Class::MOP::Class::Immutable::Trait'; sub another_method { 42 } sub superclasses { my $orig = shift; my $self = shift; $self->$orig(@_); } } { package Foo; use strict; use warnings; use metaclass; __PACKAGE__->meta->add_attribute('foo'); __PACKAGE__->meta->make_immutable; } { package Bar; use strict; use warnings; use metaclass 'My::Meta'; use base 'Foo'; __PACKAGE__->meta->add_attribute('bar'); ::is( ::exception { __PACKAGE__->meta->make_immutable }, undef, 'can safely make a class immutable when it has a custom metaclass and immutable trait' ); } { can_ok( Bar->meta, 'another_method' ); is( Bar->meta->another_method, 42, 'another_method returns expected value' ); is_deeply( [ Bar->meta->superclasses ], ['Foo'], 'Bar->meta->superclasses returns expected value after immutabilization' ); } done_testing; meta_package_extension.t100644000767000024 444112200352344 20422 0ustar00etherstaff000000000000Moose-2.1005/t/cmopuse strict; use warnings; use Test::More; use Test::Fatal; use Class::MOP; { package My::Package::Stash; use strict; use warnings; use base 'Package::Stash'; use metaclass; use Symbol 'gensym'; __PACKAGE__->meta->add_attribute( 'namespace' => ( reader => 'namespace', default => sub { {} } ) ); sub new { my $class = shift; $class->meta->new_object(__INSTANCE__ => $class->SUPER::new(@_)); } sub add_symbol { my ($self, $variable, $initial_value) = @_; (my $name = $variable) =~ s/^[\$\@\%\&]//; my $glob = gensym(); *{$glob} = $initial_value if defined $initial_value; $self->namespace->{$name} = *{$glob}; } } { package My::Meta::Package; use strict; use warnings; use base 'Class::MOP::Package'; sub _package_stash { $_[0]->{_package_stash} ||= My::Package::Stash->new($_[0]->name); } } # No actually package Foo exists :) my $meta = My::Meta::Package->initialize('Foo'); isa_ok($meta, 'My::Meta::Package'); isa_ok($meta, 'Class::MOP::Package'); ok(!defined($Foo::{foo}), '... the %foo slot has not been created yet'); ok(!$meta->has_package_symbol('%foo'), '... the meta agrees'); is( exception { $meta->add_package_symbol('%foo' => { one => 1 }); }, undef, '... the %foo symbol is created succcessfully' ); ok(!defined($Foo::{foo}), '... the %foo slot has not been created in the actual Foo package'); ok($meta->has_package_symbol('%foo'), '... the meta agrees'); my $foo = $meta->get_package_symbol('%foo'); is_deeply({ one => 1 }, $foo, '... got the right package variable back'); $foo->{two} = 2; is($foo, $meta->get_package_symbol('%foo'), '... our %foo is the same as the metas'); ok(!defined($Foo::{bar}), '... the @bar slot has not been created yet'); is( exception { $meta->add_package_symbol('@bar' => [ 1, 2, 3 ]); }, undef, '... created @Foo::bar successfully' ); ok(!defined($Foo::{bar}), '... the @bar slot has still not been created'); ok(!defined($Foo::{baz}), '... the %baz slot has not been created yet'); is( exception { $meta->add_package_symbol('%baz'); }, undef, '... created %Foo::baz successfully' ); ok(!defined($Foo::{baz}), '... the %baz slot has still not been created'); done_testing; metaclass_reinitialize.t100644000767000024 1202512200352344 20466 0ustar00etherstaff000000000000Moose-2.1005/t/cmopuse strict; use warnings; use Test::More; use Test::Fatal; { package Foo; use metaclass; sub foo {} Foo->meta->add_attribute('bar'); } sub check_meta_sanity { my ($meta, $class) = @_; isa_ok($meta, 'Class::MOP::Class'); is($meta->name, $class); ok($meta->has_method('foo')); isa_ok($meta->get_method('foo'), 'Class::MOP::Method'); ok($meta->has_attribute('bar')); isa_ok($meta->get_attribute('bar'), 'Class::MOP::Attribute'); } can_ok('Foo', 'meta'); my $meta = Foo->meta; check_meta_sanity($meta, 'Foo'); is( exception { $meta = $meta->reinitialize($meta->name); }, undef ); check_meta_sanity($meta, 'Foo'); is( exception { $meta = $meta->reinitialize($meta); }, undef ); check_meta_sanity($meta, 'Foo'); like( exception { $meta->reinitialize(''); }, qr/You must pass a package name or an existing Class::MOP::Package instance/ ); like( exception { $meta->reinitialize($meta->new_object); }, qr/You must pass a package name or an existing Class::MOP::Package instance/ ); { package Bar::Meta::Method; use base 'Class::MOP::Method'; __PACKAGE__->meta->add_attribute('test', accessor => 'test'); } { package Bar::Meta::Attribute; use base 'Class::MOP::Attribute'; __PACKAGE__->meta->add_attribute('tset', accessor => 'tset'); } { package Bar; use metaclass; Bar->meta->add_method('foo' => Bar::Meta::Method->wrap(sub {}, name => 'foo', package_name => 'Bar')); Bar->meta->add_attribute(Bar::Meta::Attribute->new('bar')); } $meta = Bar->meta; check_meta_sanity($meta, 'Bar'); isa_ok(Bar->meta->get_method('foo'), 'Bar::Meta::Method'); isa_ok(Bar->meta->get_attribute('bar'), 'Bar::Meta::Attribute'); is( exception { $meta = $meta->reinitialize('Bar'); }, undef ); check_meta_sanity($meta, 'Bar'); isa_ok(Bar->meta->get_method('foo'), 'Bar::Meta::Method'); isa_ok(Bar->meta->get_attribute('bar'), 'Bar::Meta::Attribute'); Bar->meta->get_method('foo')->test('FOO'); Bar->meta->get_attribute('bar')->tset('OOF'); is(Bar->meta->get_method('foo')->test, 'FOO'); is(Bar->meta->get_attribute('bar')->tset, 'OOF'); is( exception { $meta = $meta->reinitialize('Bar'); }, undef ); is(Bar->meta->get_method('foo')->test, 'FOO'); is(Bar->meta->get_attribute('bar')->tset, 'OOF'); { package Baz::Meta::Attribute; use base 'Class::MOP::Attribute'; } { package Baz::Meta::Method; use base 'Class::MOP::Method'; } { package Baz; use metaclass meta_name => undef; sub foo {} Class::MOP::class_of('Baz')->add_attribute('bar'); } $meta = Class::MOP::class_of('Baz'); check_meta_sanity($meta, 'Baz'); ok(!$meta->get_method('foo')->isa('Baz::Meta::Method')); ok(!$meta->get_attribute('bar')->isa('Baz::Meta::Attribute')); is( exception { $meta = $meta->reinitialize( 'Baz', attribute_metaclass => 'Baz::Meta::Attribute', method_metaclass => 'Baz::Meta::Method' ); }, undef ); check_meta_sanity($meta, 'Baz'); isa_ok($meta->get_method('foo'), 'Baz::Meta::Method'); isa_ok($meta->get_attribute('bar'), 'Baz::Meta::Attribute'); { package Quux; use metaclass attribute_metaclass => 'Bar::Meta::Attribute', method_metaclass => 'Bar::Meta::Method'; sub foo {} Quux->meta->add_attribute('bar'); } $meta = Quux->meta; check_meta_sanity($meta, 'Quux'); isa_ok(Quux->meta->get_method('foo'), 'Bar::Meta::Method'); isa_ok(Quux->meta->get_attribute('bar'), 'Bar::Meta::Attribute'); like( exception { $meta = $meta->reinitialize( 'Quux', attribute_metaclass => 'Baz::Meta::Attribute', method_metaclass => 'Baz::Meta::Method', ); }, qr/compatible/ ); { package Quuux::Meta::Attribute; use base 'Class::MOP::Attribute'; sub install_accessors {} } { package Quuux; use metaclass; sub foo {} Quuux->meta->add_attribute('bar', reader => 'bar'); } $meta = Quuux->meta; check_meta_sanity($meta, 'Quuux'); ok($meta->has_method('bar')); is( exception { $meta = $meta->reinitialize( 'Quuux', attribute_metaclass => 'Quuux::Meta::Attribute', ); }, undef ); check_meta_sanity($meta, 'Quuux'); ok(!$meta->has_method('bar')); { package Blah::Meta::Method; use base 'Class::MOP::Method'; __PACKAGE__->meta->add_attribute('foo', reader => 'foo', default => 'TEST'); } { package Blah::Meta::Attribute; use base 'Class::MOP::Attribute'; __PACKAGE__->meta->add_attribute('oof', reader => 'oof', default => 'TSET'); } { package Blah; use metaclass no_meta => 1; sub foo {} Class::MOP::class_of('Blah')->add_attribute('bar'); } $meta = Class::MOP::class_of('Blah'); check_meta_sanity($meta, 'Blah'); is( exception { $meta = Class::MOP::Class->reinitialize( 'Blah', attribute_metaclass => 'Blah::Meta::Attribute', method_metaclass => 'Blah::Meta::Method', ); }, undef ); check_meta_sanity($meta, 'Blah'); can_ok($meta->get_method('foo'), 'foo'); is($meta->get_method('foo')->foo, 'TEST'); can_ok($meta->get_attribute('bar'), 'oof'); is($meta->get_attribute('bar')->oof, 'TSET'); done_testing; example_Moose_POOP.t100644000767000024 3134612200352344 20263 0ustar00etherstaff000000000000Moose-2.1005/t/examples#!/usr/bin/perl use strict; use warnings; use Test::More; use Test::Requires { 'DBM::Deep' => '1.0003', # skip all if not installed 'DateTime::Format::MySQL' => '0.01', }; use Test::Fatal; BEGIN { # in case there are leftovers unlink('newswriter.db') if -e 'newswriter.db'; } END { unlink('newswriter.db') if -e 'newswriter.db'; } =pod This example creates a very basic Object Database which links in the instances created with a backend store (a DBM::Deep hash). It is by no means to be taken seriously as a real-world ODB, but is a proof of concept of the flexibility of the ::Instance protocol. =cut BEGIN { package MooseX::POOP::Meta::Instance; use Moose; use DBM::Deep; extends 'Moose::Meta::Instance'; { my %INSTANCE_COUNTERS; my $db = DBM::Deep->new({ file => "newswriter.db", autobless => 1, locking => 1, }); sub _reload_db { #use Data::Dumper; #warn Dumper $db; $db = undef; $db = DBM::Deep->new({ file => "newswriter.db", autobless => 1, locking => 1, }); } sub create_instance { my $self = shift; my $class = $self->associated_metaclass->name; my $oid = ++$INSTANCE_COUNTERS{$class}; $db->{$class}->[($oid - 1)] = {}; bless { oid => $oid, instance => $db->{$class}->[($oid - 1)] }, $class; } sub find_instance { my ($self, $oid) = @_; my $instance = $db->{$self->associated_metaclass->name}->[($oid - 1)]; bless { oid => $oid, instance => $instance, }, $self->associated_metaclass->name; } sub clone_instance { my ($self, $instance) = @_; my $class = $self->{meta}->name; my $oid = ++$INSTANCE_COUNTERS{$class}; my $clone = tied($instance)->clone; bless { oid => $oid, instance => $clone, }, $class; } } sub get_instance_oid { my ($self, $instance) = @_; $instance->{oid}; } sub get_slot_value { my ($self, $instance, $slot_name) = @_; return $instance->{instance}->{$slot_name}; } sub set_slot_value { my ($self, $instance, $slot_name, $value) = @_; $instance->{instance}->{$slot_name} = $value; } sub is_slot_initialized { my ($self, $instance, $slot_name, $value) = @_; exists $instance->{instance}->{$slot_name} ? 1 : 0; } sub weaken_slot_value { confess "Not sure how well DBM::Deep plays with weak refs, Rob says 'Write a test'"; } sub inline_slot_access { my ($self, $instance, $slot_name) = @_; sprintf "%s->{instance}->{%s}", $instance, $slot_name; } package MooseX::POOP::Meta::Class; use Moose; extends 'Moose::Meta::Class'; override '_construct_instance' => sub { my $class = shift; my $params = @_ == 1 ? $_[0] : {@_}; return $class->get_meta_instance->find_instance($params->{oid}) if $params->{oid}; super(); }; } { package MooseX::POOP::Object; use metaclass 'MooseX::POOP::Meta::Class' => ( instance_metaclass => 'MooseX::POOP::Meta::Instance' ); use Moose; sub oid { my $self = shift; $self->meta ->get_meta_instance ->get_instance_oid($self); } } { package Newswriter::Author; use Moose; extends 'MooseX::POOP::Object'; has 'first_name' => (is => 'rw', isa => 'Str'); has 'last_name' => (is => 'rw', isa => 'Str'); package Newswriter::Article; use Moose; use Moose::Util::TypeConstraints; use DateTime::Format::MySQL; extends 'MooseX::POOP::Object'; subtype 'Headline' => as 'Str' => where { length($_) < 100 }; subtype 'Summary' => as 'Str' => where { length($_) < 255 }; subtype 'DateTimeFormatString' => as 'Str' => where { DateTime::Format::MySQL->parse_datetime($_) }; enum 'Status' => qw(draft posted pending archive); has 'headline' => (is => 'rw', isa => 'Headline'); has 'summary' => (is => 'rw', isa => 'Summary'); has 'article' => (is => 'rw', isa => 'Str'); has 'start_date' => (is => 'rw', isa => 'DateTimeFormatString'); has 'end_date' => (is => 'rw', isa => 'DateTimeFormatString'); has 'author' => (is => 'rw', isa => 'Newswriter::Author'); has 'status' => (is => 'rw', isa => 'Status'); around 'start_date', 'end_date' => sub { my $c = shift; my $self = shift; $c->($self, DateTime::Format::MySQL->format_datetime($_[0])) if @_; DateTime::Format::MySQL->parse_datetime($c->($self) || return undef); }; } { # check the meta stuff first isa_ok(MooseX::POOP::Object->meta, 'MooseX::POOP::Meta::Class'); isa_ok(MooseX::POOP::Object->meta, 'Moose::Meta::Class'); isa_ok(MooseX::POOP::Object->meta, 'Class::MOP::Class'); is(MooseX::POOP::Object->meta->instance_metaclass, 'MooseX::POOP::Meta::Instance', '... got the right instance metaclass name'); isa_ok(MooseX::POOP::Object->meta->get_meta_instance, 'MooseX::POOP::Meta::Instance'); my $base = MooseX::POOP::Object->new; isa_ok($base, 'MooseX::POOP::Object'); isa_ok($base, 'Moose::Object'); isa_ok($base->meta, 'MooseX::POOP::Meta::Class'); isa_ok($base->meta, 'Moose::Meta::Class'); isa_ok($base->meta, 'Class::MOP::Class'); is($base->meta->instance_metaclass, 'MooseX::POOP::Meta::Instance', '... got the right instance metaclass name'); isa_ok($base->meta->get_meta_instance, 'MooseX::POOP::Meta::Instance'); } my $article_oid; { my $article; is( exception { $article = Newswriter::Article->new( headline => 'Home Office Redecorated', summary => 'The home office was recently redecorated to match the new company colors', article => '...', author => Newswriter::Author->new( first_name => 'Truman', last_name => 'Capote' ), status => 'pending' ); }, undef, '... created my article successfully' ); isa_ok($article, 'Newswriter::Article'); isa_ok($article, 'MooseX::POOP::Object'); is( exception { $article->start_date(DateTime->new(year => 2006, month => 6, day => 10)); $article->end_date(DateTime->new(year => 2006, month => 6, day => 17)); }, undef, '... add the article date-time stuff' ); ## check some meta stuff isa_ok($article->meta, 'MooseX::POOP::Meta::Class'); isa_ok($article->meta, 'Moose::Meta::Class'); isa_ok($article->meta, 'Class::MOP::Class'); is($article->meta->instance_metaclass, 'MooseX::POOP::Meta::Instance', '... got the right instance metaclass name'); isa_ok($article->meta->get_meta_instance, 'MooseX::POOP::Meta::Instance'); ok($article->oid, '... got a oid for the article'); $article_oid = $article->oid; is($article->headline, 'Home Office Redecorated', '... got the right headline'); is($article->summary, 'The home office was recently redecorated to match the new company colors', '... got the right summary'); is($article->article, '...', '... got the right article'); isa_ok($article->start_date, 'DateTime'); isa_ok($article->end_date, 'DateTime'); isa_ok($article->author, 'Newswriter::Author'); is($article->author->first_name, 'Truman', '... got the right author first name'); is($article->author->last_name, 'Capote', '... got the right author last name'); is($article->status, 'pending', '... got the right status'); } MooseX::POOP::Meta::Instance->_reload_db(); my $article2_oid; { my $article2; is( exception { $article2 = Newswriter::Article->new( headline => 'Company wins Lottery', summary => 'An email was received today that informed the company we have won the lottery', article => 'WoW', author => Newswriter::Author->new( first_name => 'Katie', last_name => 'Couric' ), status => 'posted' ); }, undef, '... created my article successfully' ); isa_ok($article2, 'Newswriter::Article'); isa_ok($article2, 'MooseX::POOP::Object'); $article2_oid = $article2->oid; is($article2->headline, 'Company wins Lottery', '... got the right headline'); is($article2->summary, 'An email was received today that informed the company we have won the lottery', '... got the right summary'); is($article2->article, 'WoW', '... got the right article'); ok(!$article2->start_date, '... these two dates are unassigned'); ok(!$article2->end_date, '... these two dates are unassigned'); isa_ok($article2->author, 'Newswriter::Author'); is($article2->author->first_name, 'Katie', '... got the right author first name'); is($article2->author->last_name, 'Couric', '... got the right author last name'); is($article2->status, 'posted', '... got the right status'); ## orig-article my $article; is( exception { $article = Newswriter::Article->new(oid => $article_oid); }, undef, '... (re)-created my article successfully' ); isa_ok($article, 'Newswriter::Article'); isa_ok($article, 'MooseX::POOP::Object'); is($article->oid, $article_oid, '... got a oid for the article'); is($article->headline, 'Home Office Redecorated', '... got the right headline'); is($article->summary, 'The home office was recently redecorated to match the new company colors', '... got the right summary'); is($article->article, '...', '... got the right article'); isa_ok($article->start_date, 'DateTime'); isa_ok($article->end_date, 'DateTime'); isa_ok($article->author, 'Newswriter::Author'); is($article->author->first_name, 'Truman', '... got the right author first name'); is($article->author->last_name, 'Capote', '... got the right author last name'); is( exception { $article->author->first_name('Dan'); $article->author->last_name('Rather'); }, undef, '... changed the value ok' ); is($article->author->first_name, 'Dan', '... got the changed author first name'); is($article->author->last_name, 'Rather', '... got the changed author last name'); is($article->status, 'pending', '... got the right status'); } MooseX::POOP::Meta::Instance->_reload_db(); { my $article; is( exception { $article = Newswriter::Article->new(oid => $article_oid); }, undef, '... (re)-created my article successfully' ); isa_ok($article, 'Newswriter::Article'); isa_ok($article, 'MooseX::POOP::Object'); is($article->oid, $article_oid, '... got a oid for the article'); is($article->headline, 'Home Office Redecorated', '... got the right headline'); is($article->summary, 'The home office was recently redecorated to match the new company colors', '... got the right summary'); is($article->article, '...', '... got the right article'); isa_ok($article->start_date, 'DateTime'); isa_ok($article->end_date, 'DateTime'); isa_ok($article->author, 'Newswriter::Author'); is($article->author->first_name, 'Dan', '... got the changed author first name'); is($article->author->last_name, 'Rather', '... got the changed author last name'); is($article->status, 'pending', '... got the right status'); my $article2; is( exception { $article2 = Newswriter::Article->new(oid => $article2_oid); }, undef, '... (re)-created my article successfully' ); isa_ok($article2, 'Newswriter::Article'); isa_ok($article2, 'MooseX::POOP::Object'); is($article2->oid, $article2_oid, '... got a oid for the article'); is($article2->headline, 'Company wins Lottery', '... got the right headline'); is($article2->summary, 'An email was received today that informed the company we have won the lottery', '... got the right summary'); is($article2->article, 'WoW', '... got the right article'); ok(!$article2->start_date, '... these two dates are unassigned'); ok(!$article2->end_date, '... these two dates are unassigned'); isa_ok($article2->author, 'Newswriter::Author'); is($article2->author->first_name, 'Katie', '... got the right author first name'); is($article2->author->last_name, 'Couric', '... got the right author last name'); is($article2->status, 'posted', '... got the right status'); } done_testing; example_Protomoose.t100644000767000024 1721712200352344 20513 0ustar00etherstaff000000000000Moose-2.1005/t/examples#!/usr/local/bin/perl use strict; use warnings; use Test::More; =pod This is an example of making Moose behave more like a prototype based object system. Why? Well cause merlyn asked if it could :) =cut ## ------------------------------------------------------------------ ## make some metaclasses { package ProtoMoose::Meta::Instance; use Moose; BEGIN { extends 'Moose::Meta::Instance' }; # NOTE: # do not let things be inlined by # the attribute or accessor generator sub is_inlinable { 0 } } { package ProtoMoose::Meta::Method::Accessor; use Moose; BEGIN { extends 'Moose::Meta::Method::Accessor' }; # customize the accessors to always grab # the correct instance in the accessors sub find_instance { my ($self, $candidate, $accessor_type) = @_; my $instance = $candidate; my $attr = $self->associated_attribute; # if it is a class calling it ... unless (blessed($instance)) { # then grab the class prototype $instance = $attr->associated_class->prototype_instance; } # if its an instance ... else { # and there is no value currently # associated with the instance and # we are trying to read it, then ... if ($accessor_type eq 'r' && !defined($attr->get_value($instance))) { # again, defer the prototype in # the class in which is was defined $instance = $attr->associated_class->prototype_instance; } # otherwise, you want to assign # to your local copy ... } return $instance; } sub _generate_accessor_method { my $self = shift; my $attr = $self->associated_attribute; return sub { if (scalar(@_) == 2) { $attr->set_value( $self->find_instance($_[0], 'w'), $_[1] ); } $attr->get_value($self->find_instance($_[0], 'r')); }; } sub _generate_reader_method { my $self = shift; my $attr = $self->associated_attribute; return sub { confess "Cannot assign a value to a read-only accessor" if @_ > 1; $attr->get_value($self->find_instance($_[0], 'r')); }; } sub _generate_writer_method { my $self = shift; my $attr = $self->associated_attribute; return sub { $attr->set_value( $self->find_instance($_[0], 'w'), $_[1] ); }; } # deal with these later ... sub generate_predicate_method {} sub generate_clearer_method {} } { package ProtoMoose::Meta::Attribute; use Moose; BEGIN { extends 'Moose::Meta::Attribute' }; sub accessor_metaclass { 'ProtoMoose::Meta::Method::Accessor' } } { package ProtoMoose::Meta::Class; use Moose; BEGIN { extends 'Moose::Meta::Class' }; has 'prototype_instance' => ( is => 'rw', isa => 'Object', predicate => 'has_prototypical_instance', lazy => 1, default => sub { (shift)->new_object } ); sub initialize { # NOTE: # I am not sure why 'around' does # not work here, have to investigate # it later - SL (shift)->SUPER::initialize(@_, instance_metaclass => 'ProtoMoose::Meta::Instance', attribute_metaclass => 'ProtoMoose::Meta::Attribute', ); } around '_construct_instance' => sub { my $next = shift; my $self = shift; # NOTE: # we actually have to do this here # to tie-the-knot, if you take it # out, then you get deep recursion # several levels deep :) $self->prototype_instance($next->($self, @_)) unless $self->has_prototypical_instance; return $self->prototype_instance; }; } { package ProtoMoose::Object; use metaclass 'ProtoMoose::Meta::Class'; use Moose; sub new { my $prototype = blessed($_[0]) ? $_[0] : $_[0]->meta->prototype_instance; my (undef, %params) = @_; my $self = $prototype->meta->clone_object($prototype, %params); $self->BUILDALL(\%params); return $self; } } ## ------------------------------------------------------------------ ## make some classes now { package Foo; use Moose; extends 'ProtoMoose::Object'; has 'bar' => (is => 'rw'); } { package Bar; use Moose; extends 'Foo'; has 'baz' => (is => 'rw'); } ## ------------------------------------------------------------------ ## ------------------------------------------------------------------ ## Check that metaclasses are working/inheriting properly foreach my $class (qw/ProtoMoose::Object Foo Bar/) { isa_ok($class->meta, 'ProtoMoose::Meta::Class', '... got the right metaclass for ' . $class . ' ->'); is($class->meta->instance_metaclass, 'ProtoMoose::Meta::Instance', '... got the right instance meta for ' . $class); is($class->meta->attribute_metaclass, 'ProtoMoose::Meta::Attribute', '... got the right attribute meta for ' . $class); } ## ------------------------------------------------------------------ # get the prototype for Foo my $foo_prototype = Foo->meta->prototype_instance; isa_ok($foo_prototype, 'Foo'); # set a value in the prototype $foo_prototype->bar(100); is($foo_prototype->bar, 100, '... got the value stored in the prototype'); # the "class" defers to the # the prototype when asked # about attributes is(Foo->bar, 100, '... got the value stored in the prototype (through the Foo class)'); # now make an instance, which # is basically a clone of the # prototype my $foo = Foo->new; isa_ok($foo, 'Foo'); # the instance is *not* the prototype isnt($foo, $foo_prototype, '... got a new instance of Foo'); # but it has the same values ... is($foo->bar, 100, '... got the value stored in the instance (inherited from the prototype)'); # we can even change the values # in the instance $foo->bar(300); is($foo->bar, 300, '... got the value stored in the instance (overwriting the one inherited from the prototype)'); # and not change the one in the prototype is($foo_prototype->bar, 100, '... got the value stored in the prototype'); is(Foo->bar, 100, '... got the value stored in the prototype (through the Foo class)'); ## subclasses # now we can check that the subclass # will seek out the correct prototypical # value from its "parent" is(Bar->bar, 100, '... got the value stored in the Foo prototype (through the Bar class)'); # we can then also set its local attrs Bar->baz(50); is(Bar->baz, 50, '... got the value stored in the prototype (through the Bar class)'); # now we clone the Bar prototype my $bar = Bar->new; isa_ok($bar, 'Bar'); isa_ok($bar, 'Foo'); # and we see that we got the right values # in the instance/clone is($bar->bar, 100, '... got the value stored in the instance (inherited from the Foo prototype)'); is($bar->baz, 50, '... got the value stored in the instance (inherited from the Bar prototype)'); # nowe we can change the value $bar->bar(200); is($bar->bar, 200, '... got the value stored in the instance (overriding the one inherited from the Foo prototype)'); # and all our original and # prototypical values are still # the same is($foo->bar, 300, '... still got the original value stored in the instance (inherited from the prototype)'); is(Foo->bar, 100, '... still got the original value stored in the prototype (through the Foo class)'); is(Bar->bar, 100, '... still got the original value stored in the prototype (through the Bar class)'); done_testing; example_w_TestDeep.t100644000767000024 271212200352344 20362 0ustar00etherstaff000000000000Moose-2.1005/t/examples#!/usr/bin/perl use strict; use warnings; use Test::More; =pod This tests how well Moose type constraints play with Test::Deep. Its not as pretty as Declare::Constraints::Simple, but it is not completely horrid either. =cut use Test::Requires { 'Test::Deep' => '0.01', # skip all if not installed }; use Test::Fatal; { package Foo; use Moose; use Moose::Util::TypeConstraints; use Test::Deep qw[ eq_deeply array_each subhashof ignore ]; # define your own type ... type 'ArrayOfHashOfBarsAndRandomNumbers' => where { eq_deeply($_, array_each( subhashof({ bar => Test::Deep::isa('Bar'), random_number => ignore() }) ) ) }; has 'bar' => ( is => 'rw', isa => 'ArrayOfHashOfBarsAndRandomNumbers', ); package Bar; use Moose; } my $array_of_hashes = [ { bar => Bar->new, random_number => 10 }, { bar => Bar->new }, ]; my $foo; is( exception { $foo = Foo->new('bar' => $array_of_hashes); }, undef, '... construction succeeded' ); isa_ok($foo, 'Foo'); is_deeply($foo->bar, $array_of_hashes, '... got our value correctly'); isnt( exception { $foo->bar({}); }, undef, '... validation failed correctly' ); isnt( exception { $foo->bar([{ foo => 3 }]); }, undef, '... validation failed correctly' ); done_testing; immutable_destroy.t100644000767000024 52512200352344 20455 0ustar00etherstaff000000000000Moose-2.1005/t/immutableuse strict; use warnings; use Test::More; { package FooBar; use Moose; has 'name' => ( is => 'ro' ); sub DESTROY { shift->name } local $SIG{__WARN__} = sub {}; __PACKAGE__->meta->make_immutable; } my $f = FooBar->new( name => 'SUSAN' ); is( $f->DESTROY, 'SUSAN', 'Did moose overload DESTROY?' ); done_testing; inline_close_over.t100644000767000024 2615312200352344 20470 0ustar00etherstaff000000000000Moose-2.1005/t/immutable#!/usr/bin/env perl use strict; use warnings; use Test::More; use Class::Load 'load_class'; use Test::Requires 'Data::Visitor'; use Test::Requires 'PadWalker'; use Try::Tiny; my $can_partialdump = try { load_class('Devel::PartialDump', { -version => 0.14 }); 1; }; { package Test::Visitor; use Moose; use Moose::Util::TypeConstraints; extends 'Data::Visitor'; has closed_over => ( traits => ['Array'], isa => 'ArrayRef', default => sub { [] }, handles => { add_closed_over => 'push', closed_over => 'elements', pass => 'is_empty', }, ); before visit_code => sub { my $self = shift; my ($code) = @_; my $closed_over = PadWalker::closed_over($code); $self->visit_ref($closed_over); }; after visit => sub { my $self = shift; my ($thing) = @_; $self->add_closed_over($thing) unless $self->_is_okay_to_close_over($thing); }; sub _is_okay_to_close_over { my $self = shift; my ($thing) = @_; match_on_type $thing => ( 'RegexpRef' => sub { 1 }, 'Object' => sub { 0 }, 'GlobRef' => sub { 0 }, 'FileHandle' => sub { 0 }, 'Any' => sub { 1 }, ); } } sub close_over_ok { local $Test::Builder::Level = $Test::Builder::Level + 1; my ($package, $method) = @_; my $visitor = Test::Visitor->new; my $code = $package->meta->find_method_by_name($method)->body; $visitor->visit($code); if ($visitor->pass) { pass("${package}::${method} didn't close over anything complicated"); } else { fail("${package}::${method} closed over some stuff:"); my @closed_over = $visitor->closed_over; for my $i (1..10) { last unless @closed_over; my $closed_over = shift @closed_over; if ($can_partialdump) { $closed_over = Devel::PartialDump->new->dump($closed_over); } diag($closed_over); } diag("... and " . scalar(@closed_over) . " more") if @closed_over; } } { package Foo; use Moose; use Moose::Util::TypeConstraints; has foo => ( is => 'ro', isa => 'Str', ); has bar => ( is => 'ro', isa => 'Int', default => 1, ); has baz => ( is => 'rw', isa => 'ArrayRef[Num]', default => sub { [ 1.2 ] }, trigger => sub { warn "blah" }, ); subtype 'Thing', as 'Int', where { $_ < 5 }, message { "must be less than 5" }; has quux => ( is => 'rw', isa => 'Thing', predicate => 'has_quux', clearer => 'clear_quux', ); __PACKAGE__->meta->make_immutable; } close_over_ok('Foo', $_) for qw(new foo bar baz quux has_quux clear_quux); { package Foo::Sub; use Moose; extends 'Foo'; around foo => sub { my $orig = shift; my $self = shift; $self->$orig(@_); }; after bar => sub { }; before baz => sub { }; override quux => sub { super }; sub blah { inner } __PACKAGE__->meta->make_immutable; } close_over_ok('Foo::Sub', $_) for qw(new foo bar baz quux blah); { package Foo::Sub::Sub; use Moose; extends 'Foo::Sub'; augment blah => { inner }; __PACKAGE__->meta->make_immutable; } close_over_ok('Foo::Sub::Sub', $_) for qw(new blah); { my %handles = ( Array => { count => 'count', elements => 'elements', is_empty => 'is_empty', push => 'push', push_curried => [ push => 42, 84 ], unshift => 'unshift', unshift_curried => [ unshift => 42, 84 ], pop => 'pop', shift => 'shift', get => 'get', get_curried => [ get => 1 ], set => 'set', set_curried_1 => [ set => 1 ], set_curried_2 => [ set => ( 1, 98 ) ], accessor => 'accessor', accessor_curried_1 => [ accessor => 1 ], accessor_curried_2 => [ accessor => ( 1, 90 ) ], clear => 'clear', delete => 'delete', delete_curried => [ delete => 1 ], insert => 'insert', insert_curried => [ insert => ( 1, 101 ) ], splice => 'splice', splice_curried_1 => [ splice => 1 ], splice_curried_2 => [ splice => 1, 2 ], splice_curried_all => [ splice => 1, 2, ( 3, 4, 5 ) ], sort => 'sort', sort_curried => [ sort => ( sub { $_[1] <=> $_[0] } ) ], sort_in_place => 'sort_in_place', sort_in_place_curried => [ sort_in_place => ( sub { $_[1] <=> $_[0] } ) ], map => 'map', map_curried => [ map => ( sub { $_ + 1 } ) ], grep => 'grep', grep_curried => [ grep => ( sub { $_ < 5 } ) ], first => 'first', first_curried => [ first => ( sub { $_ % 2 } ) ], join => 'join', join_curried => [ join => '-' ], shuffle => 'shuffle', uniq => 'uniq', reduce => 'reduce', reduce_curried => [ reduce => ( sub { $_[0] * $_[1] } ) ], natatime => 'natatime', natatime_curried => [ natatime => 2 ], }, Hash => { option_accessor => 'accessor', quantity => [ accessor => 'quantity' ], clear_options => 'clear', num_options => 'count', delete_option => 'delete', is_defined => 'defined', options_elements => 'elements', has_option => 'exists', get_option => 'get', has_no_options => 'is_empty', keys => 'keys', values => 'values', key_value => 'kv', set_option => 'set', }, Counter => { inc_counter => 'inc', inc_counter_2 => [ inc => 2 ], dec_counter => 'dec', dec_counter_2 => [ dec => 2 ], reset_counter => 'reset', set_counter => 'set', set_counter_42 => [ set => 42 ], }, Number => { abs => 'abs', add => 'add', inc => [ add => 1 ], div => 'div', cut_in_half => [ div => 2 ], mod => 'mod', odd => [ mod => 2 ], mul => 'mul', set => 'set', sub => 'sub', dec => [ sub => 1 ], }, Bool => { illuminate => 'set', darken => 'unset', flip_switch => 'toggle', is_dark => 'not', }, String => { inc => 'inc', append => 'append', append_curried => [ append => '!' ], prepend => 'prepend', prepend_curried => [ prepend => '-' ], replace => 'replace', replace_curried => [ replace => qr/(.)$/, sub { uc $1 } ], chop => 'chop', chomp => 'chomp', clear => 'clear', match => 'match', match_curried => [ match => qr/\D/ ], length => 'length', substr => 'substr', substr_curried_1 => [ substr => (1) ], substr_curried_2 => [ substr => ( 1, 3 ) ], substr_curried_3 => [ substr => ( 1, 3, 'ong' ) ], }, Code => { execute => 'execute', execute_method => 'execute_method', }, ); my %isa = ( Array => 'ArrayRef[Str]', Hash => 'HashRef[Int]', Counter => 'Int', Number => 'Num', Bool => 'Bool', String => 'Str', Code => 'CodeRef', ); my %default = ( Array => [], Hash => {}, Counter => 0, Number => 0.0, Bool => 1, String => '', Code => sub { }, ); for my $trait (keys %default) { my $class_name = "Native::$trait"; my $handles = $handles{$trait}; my $attr_class = Moose::Util::with_traits( 'Moose::Meta::Attribute', "Moose::Meta::Attribute::Native::Trait::$trait", ); Moose::Meta::Class->create( $class_name, superclasses => ['Moose::Object'], attributes => [ $attr_class->new( 'nonlazy', is => 'ro', isa => $isa{$trait}, default => sub { $default{$trait} }, handles => { map {; "nonlazy_$_" => $handles->{$_} } keys %$handles }, ), $attr_class->new( 'lazy', is => 'ro', isa => $isa{$trait}, lazy => 1, default => sub { $default{$trait} }, handles => { map {; "lazy_$_" => $handles->{$_} } keys %$handles }, ), ], ); close_over_ok($class_name, $_) for ( 'new', map {; "nonlazy_$_", "lazy_$_" } keys %$handles ); } } { package WithInitializer; use Moose; has foo => ( is => 'ro', isa => 'Str', initializer => sub { }, ); has bar => ( is => 'ro', isa => 'Str', lazy => 1, default => sub { 'a' }, initializer => sub { }, ); __PACKAGE__->meta->make_immutable; } close_over_ok('WithInitializer', 'foo'); { local $TODO = "initializer still closes over things"; close_over_ok('WithInitializer', $_) for qw(new bar); } BEGIN { package CustomErrorClass; use Moose; extends 'Moose::Error::Default'; } { package WithCustomErrorClass; use metaclass ( metaclass => 'Moose::Meta::Class', error_class => 'CustomErrorClass', ); use Moose; has foo => ( is => 'ro', isa => 'Str', ); __PACKAGE__->meta->make_immutable; } { local $TODO = "custom error classes still close over things"; close_over_ok('WithCustomErrorClass', $_) for qw(new foo); } done_testing; ensure_all_roles.t100644000767000024 177512200352344 20512 0ustar00etherstaff000000000000Moose-2.1005/t/moose_util#!/usr/bin/perl use strict; use warnings; use Test::More; use Moose::Util ':all'; { package Foo; use Moose::Role; } { package Bar; use Moose::Role; } { package Quux; use Moose; } is_deeply( Quux->meta->roles, [], "no roles yet", ); Foo->meta->apply(Quux->meta); is_deeply( Quux->meta->roles, [ Foo->meta ], "applied Foo", ); Foo->meta->apply(Quux->meta); Bar->meta->apply(Quux->meta); is_deeply( Quux->meta->roles, [ Foo->meta, Foo->meta, Bar->meta ], "duplicated Foo", ); is(does_role('Quux', 'Foo'), 1, "Quux does Foo"); is(does_role('Quux', 'Bar'), 1, "Quux does Bar"); ensure_all_roles('Quux', qw(Foo Bar)); is_deeply( Quux->meta->roles, [ Foo->meta, Foo->meta, Bar->meta ], "unchanged, since all roles are already applied", ); my $obj = Quux->new; ensure_all_roles($obj, qw(Foo Bar)); is_deeply( $obj->meta->roles, [ Foo->meta, Foo->meta, Bar->meta ], "unchanged, since all roles are already applied", ); done_testing; array_trigger.t100644000767000024 163712200352344 20510 0ustar00etherstaff000000000000Moose-2.1005/t/native_traitsuse strict; use warnings; use Test::More; { package Foo; use Moose; our @TriggerArgs; has array => ( traits => ['Array'], is => 'rw', isa => 'ArrayRef', handles => { push_array => 'push', set_array => 'set', }, clearer => 'clear_array', trigger => sub { @TriggerArgs = @_ }, ); } my $foo = Foo->new; { $foo->array( [ 1, 2, 3 ] ); is_deeply( \@Foo::TriggerArgs, [ $foo, [ 1, 2, 3 ] ], 'trigger was called for normal writer' ); $foo->push_array(5); is_deeply( \@Foo::TriggerArgs, [ $foo, [ 1, 2, 3, 5 ], [ 1, 2, 3 ] ], 'trigger was called on push' ); $foo->set_array( 1, 42 ); is_deeply( \@Foo::TriggerArgs, [ $foo, [ 1, 42, 3, 5 ], [ 1, 2, 3, 5 ] ], 'trigger was called on set' ); } done_testing; hash_subtypes.t100644000767000024 1150112200352344 20537 0ustar00etherstaff000000000000Moose-2.1005/t/native_traits#!/usr/bin/env perl use strict; use warnings; use Test::More; use Test::Fatal; { use Moose::Util::TypeConstraints; use List::Util qw( sum ); subtype 'H1', as 'HashRef[Int]'; subtype 'H2', as 'HashRef', where { scalar keys %{$_} < 2 }; subtype 'H3', as 'HashRef[Int]', where { ( sum( values %{$_} ) || 0 ) < 5 }; subtype 'H5', as 'HashRef'; coerce 'H5', from 'Str', via { { key => $_ } }; no Moose::Util::TypeConstraints; } { package Foo; use Moose; has hash_int => ( traits => ['Hash'], is => 'rw', isa => 'HashRef[Int]', handles => { set_hash_int => 'set', }, ); has h1 => ( traits => ['Hash'], is => 'rw', isa => 'H1', handles => { set_h1 => 'set', }, ); has h2 => ( traits => ['Hash'], is => 'rw', isa => 'H2', handles => { set_h2 => 'set', }, ); has h3 => ( traits => ['Hash'], is => 'rw', isa => 'H3', handles => { set_h3 => 'set', }, ); has h4 => ( traits => ['Hash'], is => 'rw', isa => 'HashRef', lazy => 1, default => 'invalid', clearer => '_clear_h4', handles => { get_h4 => 'get', accessor_h4 => 'accessor', }, ); has h5 => ( traits => ['Hash'], is => 'rw', isa => 'H5', coerce => 1, lazy => 1, default => 'invalid', clearer => '_clear_h5', handles => { get_h5 => 'get', accessor_h5 => 'accessor', }, ); } my $foo = Foo->new; { $foo->hash_int( {} ); is_deeply( $foo->hash_int, {}, "hash_int - correct contents" ); isnt( exception { $foo->set_hash_int( x => 'foo' ) }, undef, "hash_int - can't set wrong type" ); is_deeply( $foo->hash_int, {}, "hash_int - correct contents" ); $foo->set_hash_int( x => 1 ); is_deeply( $foo->hash_int, { x => 1 }, "hash_int - correct contents" ); } { isnt( exception { $foo->set_h1('foo') }, undef, "h1 - can't set onto undef" ); $foo->h1( {} ); is_deeply( $foo->h1, {}, "h1 - correct contents" ); isnt( exception { $foo->set_h1( x => 'foo' ) }, undef, "h1 - can't set wrong type" ); is_deeply( $foo->h1, {}, "h1 - correct contents" ); $foo->set_h1( x => 1 ); is_deeply( $foo->h1, { x => 1 }, "h1 - correct contents" ); } { isnt( exception { $foo->set_h2('foo') }, undef, "h2 - can't set onto undef" ); $foo->h2( {} ); is_deeply( $foo->h2, {}, "h2 - correct contents" ); $foo->set_h2( x => 'foo' ); is_deeply( $foo->h2, { x => 'foo' }, "h2 - correct contents" ); isnt( exception { $foo->set_h2( y => 'bar' ) }, undef, "h2 - can't set more than one element" ); is_deeply( $foo->h2, { x => 'foo' }, "h2 - correct contents" ); } { isnt( exception { $foo->set_h3(1) }, undef, "h3 - can't set onto undef" ); $foo->h3( {} ); is_deeply( $foo->h3, {}, "h3 - correct contents" ); isnt( exception { $foo->set_h3( x => 'foo' ) }, undef, "h3 - can't set non-int" ); isnt( exception { $foo->set_h3( x => 100 ) }, undef, "h3 - can't violate overall type constraint" ); is_deeply( $foo->h3, {}, "h3 - correct contents" ); $foo->set_h3( x => 1 ); is_deeply( $foo->h3, { x => 1 }, "h3 - correct contents" ); isnt( exception { $foo->set_h3( x => 100 ) }, undef, "h3 - can't violate overall type constraint" ); is_deeply( $foo->h3, { x => 1 }, "h3 - correct contents" ); $foo->set_h3( y => 3 ); is_deeply( $foo->h3, { x => 1, y => 3 }, "h3 - correct contents" ); } { my $expect = qr/\QAttribute (h4) does not pass the type constraint because: Validation failed for 'HashRef' with value \E.*invalid.*/; like( exception { $foo->accessor_h4('key'); }, $expect, 'invalid default is caught when trying to read via accessor' ); like( exception { $foo->accessor_h4( size => 42 ); }, $expect, 'invalid default is caught when trying to write via accessor' ); like( exception { $foo->get_h4(42); }, $expect, 'invalid default is caught when trying to get' ); } { my $foo = Foo->new; is( $foo->accessor_h5('key'), 'invalid', 'lazy default is coerced when trying to read via accessor' ); $foo->_clear_h5; $foo->accessor_h5( size => 42 ); is_deeply( $foo->h5, { key => 'invalid', size => 42 }, 'lazy default is coerced when trying to write via accessor' ); $foo->_clear_h5; is( $foo->get_h5('key'), 'invalid', 'lazy default is coerced when trying to get' ); } done_testing; shallow_clone.t100644000767000024 164412200352344 20476 0ustar00etherstaff000000000000Moose-2.1005/t/native_traits#!/usr/bin/perl use strict; use warnings; use Test::More; use Test::Fatal; use Scalar::Util qw(refaddr); { package Foo; use Moose; has 'array' => ( traits => ['Array'], is => 'ro', handles => { array_clone => 'shallow_clone' }, ); has 'hash' => ( traits => ['Hash'], is => 'ro', handles => { hash_clone => 'shallow_clone' }, ); no Moose; } my $array = [ 1, 2, 3 ]; my $hash = { a => 1, b => 2 }; my $obj = Foo->new({ array => $array, hash => $hash, }); my $array_clone = $obj->array_clone; my $hash_clone = $obj->hash_clone; isnt(refaddr($array), refaddr($array_clone), "array clone refers to new copy"); is_deeply($array_clone, $array, "...but contents are the same"); isnt(refaddr($hash), refaddr($hash_clone), "hash clone refers to new copy"); is_deeply($hash_clone, $hash, "...but contents are the same"); done_testing; trait_counter.t100644000767000024 1114212200352344 20541 0ustar00etherstaff000000000000Moose-2.1005/t/native_traits#!/usr/bin/perl use strict; use warnings; use lib 't/lib'; use Moose (); use Moose::Util::TypeConstraints; use NoInlineAttribute; use Test::Fatal; use Test::More; use Test::Moose; { my %handles = ( inc_counter => 'inc', inc_counter_2 => [ inc => 2 ], dec_counter => 'dec', dec_counter_2 => [ dec => 2 ], reset_counter => 'reset', set_counter => 'set', set_counter_42 => [ set => 42 ], ); my $name = 'Foo1'; sub build_class { my %attr = @_; my $class = Moose::Meta::Class->create( $name++, superclasses => ['Moose::Object'], ); my @traits = 'Counter'; push @traits, 'NoInlineAttribute' if delete $attr{no_inline}; $class->add_attribute( counter => ( traits => \@traits, is => 'ro', isa => 'Int', default => 0, handles => \%handles, clearer => '_clear_counter', %attr, ), ); return ( $class->name, \%handles ); } } { run_tests(build_class); run_tests( build_class( lazy => 1 ) ); run_tests( build_class( trigger => sub { } ) ); run_tests( build_class( no_inline => 1 ) ); # Will force the inlining code to check the entire hashref when it is modified. subtype 'MyInt', as 'Int', where { 1 }; run_tests( build_class( isa => 'MyInt' ) ); coerce 'MyInt', from 'Int', via { $_ }; run_tests( build_class( isa => 'MyInt', coerce => 1 ) ); } sub run_tests { my ( $class, $handles ) = @_; can_ok( $class, $_ ) for sort keys %{$handles}; with_immutable { my $obj = $class->new(); is( $obj->counter, 0, '... got the default value' ); is( $obj->inc_counter, 1, 'inc returns new value' ); is( $obj->counter, 1, '... got the incremented value' ); is( $obj->inc_counter, 2, 'inc returns new value' ); is( $obj->counter, 2, '... got the incremented value (again)' ); like( exception { $obj->inc_counter( 1, 2 ) }, qr/Cannot call inc with more than 1 argument/, 'inc throws an error when two arguments are passed' ); is( $obj->dec_counter, 1, 'dec returns new value' ); is( $obj->counter, 1, '... got the decremented value' ); like( exception { $obj->dec_counter( 1, 2 ) }, qr/Cannot call dec with more than 1 argument/, 'dec throws an error when two arguments are passed' ); is( $obj->reset_counter, 0, 'reset returns new value' ); is( $obj->counter, 0, '... got the original value' ); like( exception { $obj->reset_counter(2) }, qr/Cannot call reset with any arguments/, 'reset throws an error when an argument is passed' ); is( $obj->set_counter(5), 5, 'set returns new value' ); is( $obj->counter, 5, '... set the value' ); like( exception { $obj->set_counter( 1, 2 ) }, qr/Cannot call set with more than 1 argument/, 'set throws an error when two arguments are passed' ); $obj->inc_counter(2); is( $obj->counter, 7, '... increment by arg' ); $obj->dec_counter(5); is( $obj->counter, 2, '... decrement by arg' ); $obj->inc_counter_2; is( $obj->counter, 4, '... curried increment' ); $obj->dec_counter_2; is( $obj->counter, 2, '... curried deccrement' ); $obj->set_counter_42; is( $obj->counter, 42, '... curried set' ); if ( $class->meta->get_attribute('counter')->is_lazy ) { my $obj = $class->new; $obj->inc_counter; is( $obj->counter, 1, 'inc increments - with lazy default' ); $obj->_clear_counter; $obj->dec_counter; is( $obj->counter, -1, 'dec decrements - with lazy default' ); } } $class; } { package WithBuilder; use Moose; has nonlazy => ( traits => ['Counter'], is => 'rw', isa => 'Int', builder => '_builder', handles => { reset_nonlazy => 'reset', }, ); has lazy => ( traits => ['Counter'], is => 'rw', isa => 'Int', lazy => 1, builder => '_builder', handles => { reset_lazy => 'reset', }, ); sub _builder { 1 } } for my $attr ('lazy', 'nonlazy') { my $obj = WithBuilder->new; is($obj->$attr, 1, "built properly"); $obj->$attr(0); is($obj->$attr, 0, "can be manually set"); $obj->${\"reset_$attr"}; is($obj->$attr, 1, "reset resets it to its default value"); } done_testing; conflict_many_methods.t100644000767000024 160512200352344 20462 0ustar00etherstaff000000000000Moose-2.1005/t/roles#!/usr/bin/perl use strict; use warnings; use Test::More; use Test::Fatal; { package Bomb; use Moose::Role; sub fuse { } sub explode { } package Spouse; use Moose::Role; sub fuse { } sub explode { } package Caninish; use Moose::Role; sub bark { } package Treeve; use Moose::Role; sub bark { } } { package PracticalJoke; use Moose; ::like( ::exception { with 'Bomb', 'Spouse'; }, qr/Due to method name conflicts in roles 'Bomb' and 'Spouse', the methods 'explode' and 'fuse' must be implemented or excluded by 'PracticalJoke'/ ); ::like( ::exception { with ( 'Bomb', 'Spouse', 'Caninish', 'Treeve', ); }, qr/Due to a method name conflict in roles 'Caninish' and 'Treeve', the method 'bark' must be implemented or excluded by 'PracticalJoke'/ ); } done_testing; role_attr_application.t100644000767000024 1611112200352344 20506 0ustar00etherstaff000000000000Moose-2.1005/t/roles#!/usr/bin/env perl use strict; use warnings; use Test::More; use Test::Moose; use Moose::Util qw( does_role ); { package Foo::Meta::Attribute; use Moose::Role; } { package Foo::Meta::Attribute2; use Moose::Role; } { package Foo::Role; use Moose::Role; has foo => (is => 'ro'); } { package Foo; use Moose; Moose::Util::MetaRole::apply_metaroles( for => __PACKAGE__, class_metaroles => { attribute => ['Foo::Meta::Attribute'] }, role_metaroles => { applied_attribute => ['Foo::Meta::Attribute2'] }, ); with 'Foo::Role'; has bar => (is => 'ro'); } ok(Moose::Util::does_role(Foo->meta->get_attribute('bar'), 'Foo::Meta::Attribute'), "attrs defined in the class get the class metarole applied"); ok(!Moose::Util::does_role(Foo->meta->get_attribute('bar'), 'Foo::Meta::Attribute2'), "attrs defined in the class don't get the role metarole applied"); ok(!Moose::Util::does_role(Foo->meta->get_attribute('foo'), 'Foo::Meta::Attribute'), "attrs defined in the role don't get the metarole applied"); ok(!Moose::Util::does_role(Foo->meta->get_attribute('foo'), 'Foo::Meta::Attribute'), "attrs defined in the role don't get the role metarole defined in the class applied"); { package Bar::Meta::Attribute; use Moose::Role; } { package Bar::Meta::Attribute2; use Moose::Role; } { package Bar::Role; use Moose::Role; Moose::Util::MetaRole::apply_metaroles( for => __PACKAGE__, class_metaroles => { attribute => ['Bar::Meta::Attribute'] }, role_metaroles => { applied_attribute => ['Bar::Meta::Attribute2'] }, ); has foo => (is => 'ro'); } { package Bar; use Moose; with 'Bar::Role'; has bar => (is => 'ro'); } ok(!Moose::Util::does_role(Bar->meta->get_attribute('bar'), 'Bar::Meta::Attribute'), "attrs defined in the class don't get the class metarole from the role applied"); ok(!Moose::Util::does_role(Bar->meta->get_attribute('bar'), 'Bar::Meta::Attribute2'), "attrs defined in the class don't get the role metarole applied"); ok(Moose::Util::does_role(Bar->meta->get_attribute('foo'), 'Bar::Meta::Attribute2'), "attrs defined in the role get the role metarole applied"); ok(!Moose::Util::does_role(Bar->meta->get_attribute('foo'), 'Bar::Meta::Attribute'), "attrs defined in the role don't get the class metarole applied"); { package Baz::Meta::Attribute; use Moose::Role; } { package Baz::Meta::Attribute2; use Moose::Role; } { package Baz::Role; use Moose::Role; Moose::Util::MetaRole::apply_metaroles( for => __PACKAGE__, class_metaroles => { attribute => ['Baz::Meta::Attribute'] }, role_metaroles => { applied_attribute => ['Baz::Meta::Attribute2'] }, ); has foo => (is => 'ro'); } { package Baz; use Moose; Moose::Util::MetaRole::apply_metaroles( for => __PACKAGE__, class_metaroles => { attribute => ['Baz::Meta::Attribute'] }, role_metaroles => { applied_attribute => ['Baz::Meta::Attribute2'] }, ); with 'Baz::Role'; has bar => (is => 'ro'); } ok(Moose::Util::does_role(Baz->meta->get_attribute('bar'), 'Baz::Meta::Attribute'), "attrs defined in the class get the class metarole applied"); ok(!Moose::Util::does_role(Baz->meta->get_attribute('bar'), 'Baz::Meta::Attribute2'), "attrs defined in the class don't get the role metarole applied"); ok(Moose::Util::does_role(Baz->meta->get_attribute('foo'), 'Baz::Meta::Attribute2'), "attrs defined in the role get the role metarole applied"); ok(!Moose::Util::does_role(Baz->meta->get_attribute('foo'), 'Baz::Meta::Attribute'), "attrs defined in the role don't get the class metarole applied"); { package Accessor::Modifying::Role; use Moose::Role; around _process_options => sub { my $orig = shift; my $self = shift; my ($name, $params) = @_; $self->$orig(@_); $params->{reader} .= '_foo'; }; } { package Plain::Role; use Moose::Role; has foo => ( is => 'ro', isa => 'Str', ); } { package Class::With::Trait; use Moose; Moose::Util::MetaRole::apply_metaroles( for => __PACKAGE__, class_metaroles => { attribute => ['Accessor::Modifying::Role'], }, ); with 'Plain::Role'; has bar => ( is => 'ro', isa => 'Str', ); } { can_ok('Class::With::Trait', 'foo'); can_ok('Class::With::Trait', 'bar_foo'); } { package Role::With::Trait; use Moose::Role; Moose::Util::MetaRole::apply_metaroles( for => __PACKAGE__, role_metaroles => { applied_attribute => ['Accessor::Modifying::Role'], }, ); with 'Plain::Role'; has foo => ( is => 'ro', isa => 'Str', ); sub foo_test { my $self = shift; return $self->can('foo_foo'); } } { package Class::With::Role::With::Trait; use Moose; with 'Role::With::Trait'; has bar => ( is => 'ro', isa => 'Str', ); sub bar_test { my $self = shift; return $self->can('bar'); } } { can_ok('Class::With::Role::With::Trait', 'foo_foo'); can_ok('Class::With::Role::With::Trait', 'bar'); } { package Quux::Meta::Role::Attribute; use Moose::Role; } { package Quux::Role1; use Moose::Role; has foo => (traits => ['Quux::Meta::Role::Attribute'], is => 'ro'); has baz => (is => 'ro'); } { package Quux::Role2; use Moose::Role; Moose::Util::MetaRole::apply_metaroles( for => __PACKAGE__, role_metaroles => { applied_attribute => ['Quux::Meta::Role::Attribute'] }, ); has bar => (is => 'ro'); } { package Quux; use Moose; with 'Quux::Role1', 'Quux::Role2'; } { my $foo = Quux->meta->get_attribute('foo'); does_ok($foo, 'Quux::Meta::Role::Attribute', "individual attribute trait applied correctly"); my $baz = Quux->meta->get_attribute('baz'); ok(! does_role($baz, 'Quux::Meta::Role::Attribute'), "applied_attribute traits do not end up applying to attributes from other roles during composition"); my $bar = Quux->meta->get_attribute('bar'); does_ok($bar, 'Quux::Meta::Role::Attribute', "attribute metarole applied correctly"); } { package HasMeta; use Moose::Role; Moose::Util::MetaRole::apply_metaroles( for => __PACKAGE__, role_metaroles => { applied_attribute => ['Quux::Meta::Role::Attribute'] }, ); has foo => (is => 'ro'); } { package NoMeta; use Moose::Role; with 'HasMeta'; has bar => (is => 'ro'); } { package ConsumesBoth; use Moose; with 'HasMeta', 'NoMeta'; } { my $foo = ConsumesBoth->meta->get_attribute('foo'); does_ok($foo, 'Quux::Meta::Role::Attribute', 'applied_attribute traits are preserved when one role consumes another'); my $bar = ConsumesBoth->meta->get_attribute('bar'); ok(! does_role($bar, 'Quux::Meta::Role::Attribute'), "applied_attribute traits do not spill over from consumed role"); } done_testing; role_compose_requires.t100644000767000024 711212200352344 20516 0ustar00etherstaff000000000000Moose-2.1005/t/roles# See https://rt.cpan.org/Ticket/Display.html?id=46347 use strict; use warnings; use Test::More; use Test::Fatal; { package My::Role1; use Moose::Role; requires 'test_output'; } { package My::Role2; use Moose::Role; has test_output => ( is => 'rw' ); with 'My::Role1'; } { package My::Role3; use Moose::Role; sub test_output { } with 'My::Role1'; } { package My::Role4; use Moose::Role; has test_output => ( is => 'rw' ); } { package My::Role5; use Moose::Role; sub test_output { } } { package My::Base1; use Moose; has test_output => ( is => 'rw' ); } { package My::Base2; use Moose; sub test_output { } } # Roles providing attributes/methods should satisfy requires() of other # roles they consume. { local $TODO = "role attributes don't satisfy method requirements"; is( exception { package My::Test1; use Moose; with 'My::Role2'; }, undef, 'role2(provides attribute) consumes role1' ); } is( exception { package My::Test2; use Moose; with 'My::Role3'; }, undef, 'role3(provides method) consumes role1' ); # As I understand the design, Roles composed in the same with() statement # should NOT demonstrate ordering dependency. Alter these tests if that # assumption is false. -Vince Veselosky { local $TODO = "role attributes don't satisfy method requirements"; is( exception { package My::Test3; use Moose; with 'My::Role4', 'My::Role1'; }, undef, 'class consumes role4(provides attribute), role1' ); } { local $TODO = "role attributes don't satisfy method requirements"; is( exception { package My::Test4; use Moose; with 'My::Role1', 'My::Role4'; }, undef, 'class consumes role1, role4(provides attribute)' ); } is( exception { package My::Test5; use Moose; with 'My::Role5', 'My::Role1'; }, undef, 'class consumes role5(provides method), role1' ); is( exception { package My::Test6; use Moose; with 'My::Role1', 'My::Role5'; }, undef, 'class consumes role1, role5(provides method)' ); # Inherited methods/attributes should satisfy requires(), as long as # extends() comes first in code order. is( exception { package My::Test7; use Moose; extends 'My::Base1'; with 'My::Role1'; }, undef, 'class extends base1(provides attribute), consumes role1' ); is( exception { package My::Test8; use Moose; extends 'My::Base2'; with 'My::Role1'; }, undef, 'class extends base2(provides method), consumes role1' ); # Attributes/methods implemented in class should satisfy requires() is( exception { package My::Test9; use Moose; has 'test_output', is => 'rw'; with 'My::Role1'; }, undef, 'class provides attribute, consumes role1' ); is( exception { package My::Test10; use Moose; sub test_output { } with 'My::Role1'; }, undef, 'class provides method, consumes role1' ); # Roles composed in separate with() statements SHOULD demonstrate ordering # dependency. See comment with tests 3-6 above. is( exception { package My::Test11; use Moose; with 'My::Role4'; with 'My::Role1'; }, undef, 'class consumes role4(provides attribute); consumes role1' ); isnt( exception { package My::Test12; use Moose; with 'My::Role1'; with 'My::Role4'; }, undef, 'class consumes role1; consumes role4(provides attribute)' ); is( exception { package My::Test13; use Moose; with 'My::Role5'; with 'My::Role1'; }, undef, 'class consumes role5(provides method); consumes role1' ); isnt( exception { package My::Test14; use Moose; with 'My::Role1'; with 'My::Role5'; }, undef, 'class consumes role1; consumes role5(provides method)' ); done_testing; duck_types.t100644000767000024 350712200352344 20553 0ustar00etherstaff000000000000Moose-2.1005/t/type_constraints#!/usr/bin/perl use strict; use warnings; use Test::More; use Test::Fatal; { package Duck; use Moose; sub quack { } } { package Swan; use Moose; sub honk { } } { package RubberDuck; use Moose; sub quack { } } { package DucktypeTest; use Moose; use Moose::Util::TypeConstraints; duck_type 'DuckType' => qw(quack); duck_type 'SwanType' => [qw(honk)]; has duck => ( isa => 'DuckType', is => 'ro', lazy_build => 1, ); sub _build_duck { Duck->new } has swan => ( isa => duck_type( [qw(honk)] ), is => 'ro', ); has other_swan => ( isa => 'SwanType', is => 'ro', ); } # try giving it a duck is( exception { DucktypeTest->new( duck => Duck->new ) }, undef, 'the Duck lives okay' ); # try giving it a swan which is like a duck, but not close enough like( exception { DucktypeTest->new( duck => Swan->new ) }, qr/Swan is missing methods 'quack'/, "the Swan doesn't quack" ); # try giving it a rubber RubberDuckey is( exception { DucktypeTest->new( swan => Swan->new ) }, undef, 'but a Swan can honk' ); # try giving it a rubber RubberDuckey is( exception { DucktypeTest->new( duck => RubberDuck->new ) }, undef, 'the RubberDuck lives okay' ); # try with the other constraint form is( exception { DucktypeTest->new( other_swan => Swan->new ) }, undef, 'but a Swan can honk' ); my $re = qr/Validation failed for 'DuckType' with value/; like( exception { DucktypeTest->new( duck => undef ) }, $re, 'Exception for undef' ); like( exception { DucktypeTest->new( duck => [] ) }, $re, 'Exception for arrayref' ); like( exception { DucktypeTest->new( duck => {} ) }, $re, 'Exception for hashref' ); like( exception { DucktypeTest->new( duck => \'foo' ) }, $re, 'Exception for scalar ref' ); done_testing; type_names.t100644000767000024 260512200352344 20543 0ustar00etherstaff000000000000Moose-2.1005/t/type_constraintsuse strict; use warnings; use Test::More; use Test::Fatal; use Moose::Meta::TypeConstraint; use Moose::Util::TypeConstraints; TODO: { local $TODO = 'type names are not validated in the TC metaclass'; # Test written in this way to avoid a warning from like(undef, qr...); # -- rjbs, 2010-10-25 my $error = exception { Moose::Meta::TypeConstraint->new( name => 'Foo-Bar' ) }; if (defined $error) { like( $error, qr/contains invalid characters/, 'Type names cannot contain a dash', ); } else { fail("Type names cannot contain a dash"); } } is( exception { Moose::Meta::TypeConstraint->new( name => 'Foo.Bar::Baz' ) }, undef, 'Type names can contain periods and colons' ); like( exception { subtype 'Foo-Baz' => as 'Item' }, qr/contains invalid characters/, 'Type names cannot contain a dash (via subtype sugar)' ); is( exception { subtype 'Foo.Bar::Baz' => as 'Item' }, undef, 'Type names can contain periods and colons (via subtype sugar)' ); is( Moose::Util::TypeConstraints::find_or_parse_type_constraint('ArrayRef[In-valid]'), undef, 'find_or_parse_type_constraint returns undef on an invalid name' ); is( Moose::Util::TypeConstraints::find_or_parse_type_constraint('ArrayRef[Va.lid]'), 'ArrayRef[Va.lid]', 'find_or_parse_type_constraint returns name for valid name' ); done_testing; simple_constructor.pl100600000767000024 121212200352345 20731 0ustar00etherstaff000000000000Moose-2.1005/benchmarks#!/usr/bin/perl use strict; use warnings; my $num_iterations = shift || 100; { package Foo; use Moose; has 'default' => (is => 'rw', default => 10); has 'default_sub' => (is => 'rw', default => sub { [] }); has 'lazy' => (is => 'rw', default => 10, lazy => 1); has 'required' => (is => 'rw', required => 1); has 'weak_ref' => (is => 'rw', weak_ref => 1); has 'type_constraint' => (is => 'rw', isa => 'ArrayRef'); } foreach (0 .. $num_iterations) { my $foo = Foo->new( required => 'BAR', type_constraint => [], weak_ref => {}, ); }Bench000755000767000024 012200352345 17035 5ustar00etherstaff000000000000Moose-2.1005/benchmarks/cmop/libRun.pm100644000767000024 175212200352345 20304 0ustar00etherstaff000000000000Moose-2.1005/benchmarks/cmop/lib/Bench#!/usr/bin/perl package Bench::Run; use Moose; use Benchmark qw/:hireswallclock :all/; has classes => ( isa => "ArrayRef", is => "rw", auto_deref => 1, ); has benchmarks => ( isa => "ArrayRef", is => "rw", auto_deref => 1, ); has min_time => ( isa => "Num", is => "rw", default => 5, ); sub run { my $self = shift; foreach my $bench ( $self->benchmarks ) { my $bench_class = delete $bench->{class}; my $name = delete $bench->{name} || $bench_class; my @bench_args = %$bench; eval "require $bench_class"; die $@ if $@; my %res; foreach my $class ( $self->classes ) { eval "require $class"; die $@ if $@; my $b = $bench_class->new( @bench_args, class => $class ); $res{$class} = countit( $self->min_time, $b->code ); } print "- $name:\n"; cmpthese( \%res ); print "\n"; } } __PACKAGE__; __END__ MOP000755000767000024 012200352345 16451 5ustar00etherstaff000000000000Moose-2.1005/benchmarks/cmop/libPoint.pm100644000767000024 54112200352345 20220 0ustar00etherstaff000000000000Moose-2.1005/benchmarks/cmop/lib/MOP package MOP::Point; use strict; use warnings; use metaclass; __PACKAGE__->meta->add_attribute('x' => (accessor => 'x', default => 10)); __PACKAGE__->meta->add_attribute('y' => (accessor => 'y')); sub new { my $class = shift; $class->meta->new_object(@_); } sub clear { my $self = shift; $self->x(0); $self->y(0); } 1; __END__ Accessor.pm100644000767000024 1754112200352345 20153 0ustar00etherstaff000000000000Moose-2.1005/lib/Class/MOP/Method package Class::MOP::Method::Accessor; BEGIN { $Class::MOP::Method::Accessor::AUTHORITY = 'cpan:STEVAN'; } { $Class::MOP::Method::Accessor::VERSION = '2.1005'; } use strict; use warnings; use Carp 'confess'; use Scalar::Util 'blessed', 'weaken'; use Try::Tiny; use base 'Class::MOP::Method::Generated'; sub new { my $class = shift; my %options = @_; (exists $options{attribute}) || confess "You must supply an attribute to construct with"; (exists $options{accessor_type}) || confess "You must supply an accessor_type to construct with"; (blessed($options{attribute}) && $options{attribute}->isa('Class::MOP::Attribute')) || confess "You must supply an attribute which is a 'Class::MOP::Attribute' instance"; ($options{package_name} && $options{name}) || confess "You must supply the package_name and name parameters $Class::MOP::Method::UPGRADE_ERROR_TEXT"; my $self = $class->_new(\%options); # we don't want this creating # a cycle in the code, if not # needed weaken($self->{'attribute'}); $self->_initialize_body; return $self; } sub _new { my $class = shift; return Class::MOP::Class->initialize($class)->new_object(@_) if $class ne __PACKAGE__; my $params = @_ == 1 ? $_[0] : {@_}; return bless { # inherited from Class::MOP::Method body => $params->{body}, associated_metaclass => $params->{associated_metaclass}, package_name => $params->{package_name}, name => $params->{name}, original_method => $params->{original_method}, # inherit from Class::MOP::Generated is_inline => $params->{is_inline} || 0, definition_context => $params->{definition_context}, # defined in this class attribute => $params->{attribute}, accessor_type => $params->{accessor_type}, } => $class; } ## accessors sub associated_attribute { (shift)->{'attribute'} } sub accessor_type { (shift)->{'accessor_type'} } ## factory sub _initialize_body { my $self = shift; my $method_name = join "_" => ( '_generate', $self->accessor_type, 'method', ($self->is_inline ? 'inline' : ()) ); $self->{'body'} = $self->$method_name(); } ## generators sub _generate_accessor_method { my $self = shift; my $attr = $self->associated_attribute; return sub { if (@_ >= 2) { $attr->set_value($_[0], $_[1]); } $attr->get_value($_[0]); }; } sub _generate_accessor_method_inline { my $self = shift; my $attr = $self->associated_attribute; return try { $self->_compile_code([ 'sub {', 'if (@_ > 1) {', $attr->_inline_set_value('$_[0]', '$_[1]'), '}', $attr->_inline_get_value('$_[0]'), '}', ]); } catch { confess "Could not generate inline accessor because : $_"; }; } sub _generate_reader_method { my $self = shift; my $attr = $self->associated_attribute; return sub { confess "Cannot assign a value to a read-only accessor" if @_ > 1; $attr->get_value($_[0]); }; } sub _generate_reader_method_inline { my $self = shift; my $attr = $self->associated_attribute; return try { $self->_compile_code([ 'sub {', 'if (@_ > 1) {', # XXX: this is a hack, but our error stuff is terrible $self->_inline_throw_error( '"Cannot assign a value to a read-only accessor"', 'data => \@_' ) . ';', '}', $attr->_inline_get_value('$_[0]'), '}', ]); } catch { confess "Could not generate inline reader because : $_"; }; } sub _inline_throw_error { my $self = shift; return 'Carp::confess ' . $_[0]; } sub _generate_writer_method { my $self = shift; my $attr = $self->associated_attribute; return sub { $attr->set_value($_[0], $_[1]); }; } sub _generate_writer_method_inline { my $self = shift; my $attr = $self->associated_attribute; return try { $self->_compile_code([ 'sub {', $attr->_inline_set_value('$_[0]', '$_[1]'), '}', ]); } catch { confess "Could not generate inline writer because : $_"; }; } sub _generate_predicate_method { my $self = shift; my $attr = $self->associated_attribute; return sub { $attr->has_value($_[0]) }; } sub _generate_predicate_method_inline { my $self = shift; my $attr = $self->associated_attribute; return try { $self->_compile_code([ 'sub {', $attr->_inline_has_value('$_[0]'), '}', ]); } catch { confess "Could not generate inline predicate because : $_"; }; } sub _generate_clearer_method { my $self = shift; my $attr = $self->associated_attribute; return sub { $attr->clear_value($_[0]) }; } sub _generate_clearer_method_inline { my $self = shift; my $attr = $self->associated_attribute; return try { $self->_compile_code([ 'sub {', $attr->_inline_clear_value('$_[0]'), '}', ]); } catch { confess "Could not generate inline clearer because : $_"; }; } 1; # ABSTRACT: Method Meta Object for accessors __END__ =pod =head1 NAME Class::MOP::Method::Accessor - Method Meta Object for accessors =head1 VERSION version 2.1005 =head1 SYNOPSIS use Class::MOP::Method::Accessor; my $reader = Class::MOP::Method::Accessor->new( attribute => $attribute, is_inline => 1, accessor_type => 'reader', ); $reader->body->execute($instance); # call the reader method =head1 DESCRIPTION This is a subclass of C which is used by C to generate accessor code. It handles generation of readers, writers, predicates and clearers. For each type of method, it can either create a subroutine reference, or actually inline code by generating a string and C'ing it. =head1 METHODS =over 4 =item B<< Class::MOP::Method::Accessor->new(%options) >> This returns a new C based on the C<%options> provided. =over 4 =item * attribute This is the C for which accessors are being generated. This option is required. =item * accessor_type This is a string which should be one of "reader", "writer", "accessor", "predicate", or "clearer". This is the type of method being generated. This option is required. =item * is_inline This indicates whether or not the accessor should be inlined. This defaults to false. =item * name The method name (without a package name). This is required. =item * package_name The package name for the method. This is required. =back =item B<< $metamethod->accessor_type >> Returns the accessor type which was passed to C. =item B<< $metamethod->is_inline >> Returns a boolean indicating whether or not the accessor is inlined. =item B<< $metamethod->associated_attribute >> This returns the L object which was passed to C. =item B<< $metamethod->body >> The method itself is I when the accessor object is constructed. =back =head1 AUTHOR Moose is maintained by the Moose Cabal, along with the help of many contributors. See L and L for details. =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2013 by Infinity Interactive, Inc.. This is free software; you can redistribute it and/or modify it under the same terms as the Perl 5 programming language system itself. =cut Overload.pm100644000767000024 444412200352345 20142 0ustar00etherstaff000000000000Moose-2.1005/lib/Class/MOP/Method package Class::MOP::Method::Overload; BEGIN { $Class::MOP::Method::Overload::AUTHORITY = 'cpan:STEVAN'; } { $Class::MOP::Method::Overload::VERSION = '2.1005'; } use strict; use warnings; use Carp 'confess'; use base 'Class::MOP::Method'; sub wrap { my $class = shift; my (@args) = @_; unshift @args, 'body' if @args % 2 == 1; my %params = @args; confess "operator is required" unless exists $params{operator}; return $class->SUPER::wrap( name => "($params{operator}", %params, ); } sub _new { my $class = shift; return Class::MOP::Class->initialize($class)->new_object(@_) if $class ne __PACKAGE__; my $params = @_ == 1 ? $_[0] : {@_}; return bless { # inherited from Class::MOP::Method 'body' => $params->{body}, 'associated_metaclass' => $params->{associated_metaclass}, 'package_name' => $params->{package_name}, 'name' => $params->{name}, 'original_method' => $params->{original_method}, # defined in this class 'operator' => $params->{operator}, } => $class; } 1; # ABSTRACT: Method Meta Object for methods which implement overloading __END__ =pod =head1 NAME Class::MOP::Method::Overload - Method Meta Object for methods which implement overloading =head1 VERSION version 2.1005 =head1 DESCRIPTION This is a L subclass which represents methods that implement overloading. =head1 METHODS =over 4 =item B<< Class::MOP::Method::Overload->wrap($metamethod, %options) >> This is the constructor. The options accepted are identical to the ones accepted by L, except that it also required an C parameter, which should be an operator as defined by the L pragma. =item B<< $metamethod->operator >> This returns the operator that was passed to new. =back =head1 AUTHOR Moose is maintained by the Moose Cabal, along with the help of many contributors. See L and L for details. =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2013 by Infinity Interactive, Inc.. This is free software; you can redistribute it and/or modify it under the same terms as the Perl 5 programming language system itself. =cut Unsweetened.pod100644000767000024 2042312200352345 20415 0ustar00etherstaff000000000000Moose-2.1005/lib/Moose/Manualpackage Moose::Manual::Unsweetened; # ABSTRACT: Moose idioms in plain old Perl 5 without the sugar __END__ =pod =head1 NAME Moose::Manual::Unsweetened - Moose idioms in plain old Perl 5 without the sugar =head1 VERSION version 2.1005 =head1 DESCRIPTION If you're trying to figure out just what the heck Moose does, and how it saves you time, you might find it helpful to see what Moose is I doing for you. This document shows you the translation from Moose sugar back to plain old Perl 5. =head1 CLASSES AND ATTRIBUTES First, we define two very small classes the Moose way. package Person; use DateTime; use DateTime::Format::Natural; use Moose; use Moose::Util::TypeConstraints; has name => ( is => 'rw', isa => 'Str', required => 1, ); # Moose doesn't know about non-Moose-based classes. class_type 'DateTime'; my $en_parser = DateTime::Format::Natural->new( lang => 'en', time_zone => 'UTC', ); coerce 'DateTime' => from 'Str' => via { $en_parser->parse_datetime($_) }; has birth_date => ( is => 'rw', isa => 'DateTime', coerce => 1, handles => { birth_year => 'year' }, ); enum 'ShirtSize' => qw( s m l xl xxl ); has shirt_size => ( is => 'rw', isa => 'ShirtSize', default => 'l', ); This is a fairly simple class with three attributes. We also define an enum type to validate t-shirt sizes because we don't want to end up with something like "blue" for the shirt size! package User; use Email::Valid; use Moose; use Moose::Util::TypeConstraints; extends 'Person'; subtype 'Email' => as 'Str' => where { Email::Valid->address($_) } => message { "$_ is not a valid email address" }; has email_address => ( is => 'rw', isa => 'Email', required => 1, ); This class subclasses Person to add a single attribute, email address. Now we will show what these classes would look like in plain old Perl 5. For the sake of argument, we won't use any base classes or any helpers like C. package Person; use strict; use warnings; use Carp qw( confess ); use DateTime; use DateTime::Format::Natural; sub new { my $class = shift; my %p = ref $_[0] ? %{ $_[0] } : @_; exists $p{name} or confess 'name is a required attribute'; $class->_validate_name( $p{name} ); exists $p{birth_date} or confess 'birth_date is a required attribute'; $p{birth_date} = $class->_coerce_birth_date( $p{birth_date} ); $class->_validate_birth_date( $p{birth_date} ); $p{shirt_size} = 'l' unless exists $p{shirt_size}: $class->_validate_shirt_size( $p{shirt_size} ); return bless \%p, $class; } sub _validate_name { shift; my $name = shift; local $Carp::CarpLevel = $Carp::CarpLevel + 1; defined $name or confess 'name must be a string'; } { my $en_parser = DateTime::Format::Natural->new( lang => 'en', time_zone => 'UTC', ); sub _coerce_birth_date { shift; my $date = shift; return $date unless defined $date && ! ref $date; my $dt = $en_parser->parse_datetime($date); return $dt ? $dt : undef; } } sub _validate_birth_date { shift; my $birth_date = shift; local $Carp::CarpLevel = $Carp::CarpLevel + 1; $birth_date->isa('DateTime') or confess 'birth_date must be a DateTime object'; } sub _validate_shirt_size { shift; my $shirt_size = shift; local $Carp::CarpLevel = $Carp::CarpLevel + 1; defined $shirt_size or confess 'shirt_size cannot be undef'; my %sizes = map { $_ => 1 } qw( s m l xl xxl ); $sizes{$shirt_size} or confess "$shirt_size is not a valid shirt size (s, m, l, xl, xxl)"; } sub name { my $self = shift; if (@_) { $self->_validate_name( $_[0] ); $self->{name} = $_[0]; } return $self->{name}; } sub birth_date { my $self = shift; if (@_) { my $date = $self->_coerce_birth_date( $_[0] ); $self->_validate_birth_date( $date ); $self->{birth_date} = $date; } return $self->{birth_date}; } sub birth_year { my $self = shift; return $self->birth_date->year; } sub shirt_size { my $self = shift; if (@_) { $self->_validate_shirt_size( $_[0] ); $self->{shirt_size} = $_[0]; } return $self->{shirt_size}; } Wow, that was a mouthful! One thing to note is just how much space the data validation code consumes. As a result, it's pretty common for Perl 5 programmers to just not bother. Unfortunately, not validating arguments leads to surprises down the line ("why is birth_date an email address?"). Also, did you spot the (intentional) bug? It's in the C<_validate_birth_date()> method. We should check that the value in C<$birth_date> is actually defined and an object before we go and call C on it! Leaving out those checks means our data validation code could actually cause our program to die. Oops. Note that if we add a superclass to Person we'll have to change the constructor to account for that. (As an aside, getting all the little details of what Moose does for you just right in this example was really not easy, which emphasizes the point of the example. Moose saves you a lot of work!) Now let's see User: package User; use strict; use warnings; use Carp qw( confess ); use Email::Valid; use Scalar::Util qw( blessed ); use base 'Person'; sub new { my $class = shift; my %p = ref $_[0] ? %{ $_[0] } : @_; exists $p{email_address} or confess 'email_address is a required attribute'; $class->_validate_email_address( $p{email_address} ); my $self = $class->SUPER::new(%p); $self->{email_address} = $p{email_address}; return $self; } sub _validate_email_address { shift; my $email_address = shift; local $Carp::CarpLevel = $Carp::CarpLevel + 1; defined $email_address or confess 'email_address must be a string'; Email::Valid->address($email_address) or confess "$email_address is not a valid email address"; } sub email_address { my $self = shift; if (@_) { $self->_validate_email_address( $_[0] ); $self->{email_address} = $_[0]; } return $self->{email_address}; } That one was shorter, but it only has one attribute. Between the two classes, we have a whole lot of code that doesn't do much. We could probably simplify this by defining some sort of "attribute and validation" hash, like this: package Person; my %Attr = ( name => { required => 1, validate => sub { defined $_ }, }, birth_date => { required => 1, validate => sub { blessed $_ && $_->isa('DateTime') }, }, shirt_size => { required => 1, validate => sub { defined $_ && $_ =~ /^(?:s|m|l|xl|xxl)$/i }, } ); Then we could define a base class that would accept such a definition, and do the right thing. Keep that sort of thing up and we're well on our way to writing a half-assed version of Moose! Of course, there are CPAN modules that do some of what Moose does, like C, C, and so on. But none of them put together all of Moose's features along with a layer of declarative sugar, nor are these other modules designed for extensibility in the same way as Moose. With Moose, it's easy to write a MooseX module to replace or extend a piece of built-in functionality. Moose is a complete OO package in and of itself, and is part of a rich ecosystem of extensions. It also has an enthusiastic community of users, and is being actively maintained and developed. =head1 AUTHOR Moose is maintained by the Moose Cabal, along with the help of many contributors. See L and L for details. =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2013 by Infinity Interactive, Inc.. This is free software; you can redistribute it and/or modify it under the same terms as the Perl 5 programming language system itself. =cut TypeConstraint.pm100644000767000024 4123312200352345 20422 0ustar00etherstaff000000000000Moose-2.1005/lib/Moose/Meta package Moose::Meta::TypeConstraint; BEGIN { $Moose::Meta::TypeConstraint::AUTHORITY = 'cpan:STEVAN'; } { $Moose::Meta::TypeConstraint::VERSION = '2.1005'; } use strict; use warnings; use metaclass; use overload '0+' => sub { refaddr(shift) }, # id an object '""' => sub { shift->name }, # stringify to tc name bool => sub { 1 }, fallback => 1; use Carp qw(confess); use Class::Load qw(load_class); use Eval::Closure; use Scalar::Util qw(blessed refaddr); use Sub::Name qw(subname); use Try::Tiny; use base qw(Class::MOP::Object); __PACKAGE__->meta->add_attribute('name' => ( reader => 'name', Class::MOP::_definition_context(), )); __PACKAGE__->meta->add_attribute('parent' => ( reader => 'parent', predicate => 'has_parent', Class::MOP::_definition_context(), )); my $null_constraint = sub { 1 }; __PACKAGE__->meta->add_attribute('constraint' => ( reader => 'constraint', writer => '_set_constraint', default => sub { $null_constraint }, Class::MOP::_definition_context(), )); __PACKAGE__->meta->add_attribute('message' => ( accessor => 'message', predicate => 'has_message', Class::MOP::_definition_context(), )); __PACKAGE__->meta->add_attribute('_default_message' => ( accessor => '_default_message', Class::MOP::_definition_context(), )); # can't make this a default because it has to close over the type name, and # cmop attributes don't have lazy my $_default_message_generator = sub { my $name = shift; sub { my $value = shift; # have to load it late like this, since it uses Moose itself my $can_partialdump = try { # versions prior to 0.14 had a potential infinite loop bug load_class('Devel::PartialDump', { -version => 0.14 }); 1; }; if ($can_partialdump) { $value = Devel::PartialDump->new->dump($value); } else { $value = (defined $value ? overload::StrVal($value) : 'undef'); } return "Validation failed for '" . $name . "' with value $value"; } }; __PACKAGE__->meta->add_attribute('coercion' => ( accessor => 'coercion', predicate => 'has_coercion', Class::MOP::_definition_context(), )); __PACKAGE__->meta->add_attribute('hand_optimized_type_constraint' => ( init_arg => 'optimized', accessor => 'hand_optimized_type_constraint', predicate => 'has_hand_optimized_type_constraint', Class::MOP::_definition_context(), )); __PACKAGE__->meta->add_attribute('inlined' => ( init_arg => 'inlined', accessor => 'inlined', predicate => '_has_inlined_type_constraint', Class::MOP::_definition_context(), )); __PACKAGE__->meta->add_attribute('inline_environment' => ( init_arg => 'inline_environment', accessor => '_inline_environment', default => sub { {} }, Class::MOP::_definition_context(), )); sub parents { my $self = shift; $self->parent; } # private accessors __PACKAGE__->meta->add_attribute('compiled_type_constraint' => ( accessor => '_compiled_type_constraint', predicate => '_has_compiled_type_constraint', Class::MOP::_definition_context(), )); __PACKAGE__->meta->add_attribute('package_defined_in' => ( accessor => '_package_defined_in', Class::MOP::_definition_context(), )); sub new { my $class = shift; my ($first, @rest) = @_; my %args = ref $first ? %$first : $first ? ($first, @rest) : (); $args{name} = $args{name} ? "$args{name}" : "__ANON__"; if ( $args{optimized} ) { Moose::Deprecated::deprecated( feature => 'optimized type constraint sub ref', message => 'Providing an optimized subroutine ref for type constraints is deprecated.' . ' Use the inlining feature (inline_as) instead.' ); } if ( exists $args{message} && (!ref($args{message}) || ref($args{message}) ne 'CODE') ) { confess("The 'message' parameter must be a coderef"); } my $self = $class->_new(%args); $self->compile_type_constraint() unless $self->_has_compiled_type_constraint; $self->_default_message($_default_message_generator->($self->name)) unless $self->has_message; return $self; } sub coerce { my $self = shift; my $coercion = $self->coercion; unless ($coercion) { require Moose; Moose->throw_error("Cannot coerce without a type coercion"); } return $_[0] if $self->check($_[0]); return $coercion->coerce(@_); } sub assert_coerce { my $self = shift; my $result = $self->coerce(@_); $self->assert_valid($result); return $result; } sub check { my ($self, @args) = @_; my $constraint_subref = $self->_compiled_type_constraint; return $constraint_subref->(@args) ? 1 : undef; } sub validate { my ($self, $value) = @_; if ($self->_compiled_type_constraint->($value)) { return undef; } else { $self->get_message($value); } } sub can_be_inlined { my $self = shift; if ( $self->has_parent && $self->constraint == $null_constraint ) { return $self->parent->can_be_inlined; } return $self->_has_inlined_type_constraint; } sub _inline_check { my $self = shift; unless ( $self->can_be_inlined ) { require Moose; Moose->throw_error( 'Cannot inline a type constraint check for ' . $self->name ); } if ( $self->has_parent && $self->constraint == $null_constraint ) { return $self->parent->_inline_check(@_); } return '( do { ' . $self->inlined->( $self, @_ ) . ' } )'; } sub inline_environment { my $self = shift; if ( $self->has_parent && $self->constraint == $null_constraint ) { return $self->parent->inline_environment; } return $self->_inline_environment; } sub assert_valid { my ($self, $value) = @_; my $error = $self->validate($value); return 1 if ! defined $error; require Moose; Moose->throw_error($error); } sub get_message { my ($self, $value) = @_; my $msg = $self->has_message ? $self->message : $self->_default_message; local $_ = $value; return $msg->($value); } ## type predicates ... sub equals { my ( $self, $type_or_name ) = @_; my $other = Moose::Util::TypeConstraints::find_type_constraint($type_or_name) or return; return 1 if $self == $other; if ( $self->has_hand_optimized_type_constraint and $other->has_hand_optimized_type_constraint ) { return 1 if $self->hand_optimized_type_constraint == $other->hand_optimized_type_constraint; } return unless $self->constraint == $other->constraint; if ( $self->has_parent ) { return unless $other->has_parent; return unless $self->parent->equals( $other->parent ); } else { return if $other->has_parent; } return; } sub is_a_type_of { my ($self, $type_or_name) = @_; my $type = Moose::Util::TypeConstraints::find_type_constraint($type_or_name) or return; ($self->equals($type) || $self->is_subtype_of($type)); } sub is_subtype_of { my ($self, $type_or_name) = @_; my $type = Moose::Util::TypeConstraints::find_type_constraint($type_or_name) or return; my $current = $self; while (my $parent = $current->parent) { return 1 if $parent->equals($type); $current = $parent; } return 0; } ## compiling the type constraint sub compile_type_constraint { my $self = shift; $self->_compiled_type_constraint($self->_actually_compile_type_constraint); } ## type compilers ... sub _actually_compile_type_constraint { my $self = shift; return $self->_compile_hand_optimized_type_constraint if $self->has_hand_optimized_type_constraint; if ( $self->can_be_inlined ) { return eval_closure( source => 'sub { ' . $self->_inline_check('$_[0]') . ' }', environment => $self->inline_environment, ); } my $check = $self->constraint; unless ( defined $check ) { require Moose; Moose->throw_error( "Could not compile type constraint '" . $self->name . "' because no constraint check" ); } return $self->_compile_subtype($check) if $self->has_parent; return $self->_compile_type($check); } sub _compile_hand_optimized_type_constraint { my $self = shift; my $type_constraint = $self->hand_optimized_type_constraint; unless ( ref $type_constraint ) { require Moose; Moose->throw_error("Hand optimized type constraint is not a code reference"); } return $type_constraint; } sub _compile_subtype { my ($self, $check) = @_; # gather all the parent constraints in order my @parents; my $optimized_parent; foreach my $parent ($self->_collect_all_parents) { # if a parent is optimized, the optimized constraint already includes # all of its parents tcs, so we can break the loop if ($parent->has_hand_optimized_type_constraint) { push @parents => $optimized_parent = $parent->hand_optimized_type_constraint; last; } else { push @parents => $parent->constraint; } } @parents = grep { $_ != $null_constraint } reverse @parents; unless ( @parents ) { return $self->_compile_type($check); } elsif( $optimized_parent and @parents == 1 ) { # the case of just one optimized parent is optimized to prevent # looping and the unnecessary localization if ( $check == $null_constraint ) { return $optimized_parent; } else { return subname($self->name, sub { return undef unless $optimized_parent->($_[0]); my (@args) = @_; local $_ = $args[0]; $check->(@args); }); } } else { # general case, check all the constraints, from the first parent to ourselves my @checks = @parents; push @checks, $check if $check != $null_constraint; return subname($self->name => sub { my (@args) = @_; local $_ = $args[0]; foreach my $check (@checks) { return undef unless $check->(@args); } return 1; }); } } sub _compile_type { my ($self, $check) = @_; return $check if $check == $null_constraint; # Item, Any return subname($self->name => sub { my (@args) = @_; local $_ = $args[0]; $check->(@args); }); } ## other utils ... sub _collect_all_parents { my $self = shift; my @parents; my $current = $self->parent; while (defined $current) { push @parents => $current; $current = $current->parent; } return @parents; } sub create_child_type { my ($self, %opts) = @_; my $class = ref $self; return $class->new(%opts, parent => $self); } 1; # ABSTRACT: The Moose Type Constraint metaclass __END__ =pod =head1 NAME Moose::Meta::TypeConstraint - The Moose Type Constraint metaclass =head1 VERSION version 2.1005 =head1 DESCRIPTION This class represents a single type constraint. Moose's built-in type constraints, as well as constraints you define, are all stored in a L object as objects of this class. =head1 INHERITANCE C is a subclass of L. =head1 METHODS =over 4 =item B<< Moose::Meta::TypeConstraint->new(%options) >> This creates a new type constraint based on the provided C<%options>: =over 8 =item * name The constraint name. If a name is not provided, it will be set to "__ANON__". =item * parent A C object which is the parent type for the type being created. This is optional. =item * constraint This is the subroutine reference that implements the actual constraint check. This defaults to a subroutine which always returns true. =item * message A subroutine reference which is used to generate an error message when the constraint fails. This is optional. =item * coercion A L object representing the coercions to the type. This is optional. =item * inlined A subroutine which returns a string suitable for inlining this type constraint. It will be called as a method on the type constraint object, and will receive a single additional parameter, a variable name to be tested (usually C<"$_"> or C<"$_[0]">. This is optional. =item * inline_environment A hash reference of variables to close over. The keys are variables names, and the values are I to the variables. =item * optimized B This is a variant of the C parameter that is somehow optimized. Typically, this means incorporating both the type's constraint and all of its parents' constraints into a single subroutine reference. =back =item B<< $constraint->equals($type_name_or_object) >> Returns true if the supplied name or type object is the same as the current type. =item B<< $constraint->is_subtype_of($type_name_or_object) >> Returns true if the supplied name or type object is a parent of the current type. =item B<< $constraint->is_a_type_of($type_name_or_object) >> Returns true if the given type is the same as the current type, or is a parent of the current type. This is a shortcut for checking C and C. =item B<< $constraint->coerce($value) >> This will attempt to coerce the value to the type. If the type does not have any defined coercions this will throw an error. If no coercion can produce a value matching C<$constraint>, the original value is returned. =item B<< $constraint->assert_coerce($value) >> This method behaves just like C, but if the result is not valid according to C<$constraint>, an error is thrown. =item B<< $constraint->check($value) >> Returns true if the given value passes the constraint for the type. =item B<< $constraint->validate($value) >> This is similar to C. However, if the type I then the method returns an explicit C. If the type is not valid, we call C<< $self->get_message($value) >> internally to generate an error message. =item B<< $constraint->assert_valid($value) >> Like C and C, this method checks whether C<$value> is valid under the constraint. If it is, it will return true. If it is not, an exception will be thrown with the results of C<< $self->get_message($value) >>. =item B<< $constraint->name >> Returns the type's name, as provided to the constructor. =item B<< $constraint->parent >> Returns the type's parent, as provided to the constructor, if any. =item B<< $constraint->has_parent >> Returns true if the type has a parent type. =item B<< $constraint->parents >> Returns all of the types parents as an list of type constraint objects. =item B<< $constraint->constraint >> Returns the type's constraint, as provided to the constructor. =item B<< $constraint->get_message($value) >> This generates a method for the given value. If the type does not have an explicit message, we generate a default message. =item B<< $constraint->has_message >> Returns true if the type has a message. =item B<< $constraint->message >> Returns the type's message as a subroutine reference. =item B<< $constraint->coercion >> Returns the type's L object, if one exists. =item B<< $constraint->has_coercion >> Returns true if the type has a coercion. =item B<< $constraint->can_be_inlined >> Returns true if this type constraint can be inlined. A type constraint which subtypes an inlinable constraint and does not add an additional constraint "inherits" its parent type's inlining. =item B<< $constraint->hand_optimized_type_constraint >> B Returns the type's hand optimized constraint, as provided to the constructor via the C option. =item B<< $constraint->has_hand_optimized_type_constraint >> B Returns true if the type has an optimized constraint. =item B<< $constraint->create_child_type(%options) >> This returns a new type constraint of the same class using the provided C<%options>. The C option will be the current type. This method exists so that subclasses of this class can override this behavior and change how child types are created. =back =head1 BUGS See L for details on reporting bugs. =head1 AUTHOR Moose is maintained by the Moose Cabal, along with the help of many contributors. See L and L for details. =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2013 by Infinity Interactive, Inc.. This is free software; you can redistribute it and/or modify it under the same terms as the Perl 5 programming language system itself. =cut Attribute.pm100644000767000024 1232112200352345 20274 0ustar00etherstaff000000000000Moose-2.1005/lib/Moose/Meta/Rolepackage Moose::Meta::Role::Attribute; BEGIN { $Moose::Meta::Role::Attribute::AUTHORITY = 'cpan:STEVAN'; } { $Moose::Meta::Role::Attribute::VERSION = '2.1005'; } use strict; use warnings; use Carp 'confess'; use List::MoreUtils 'all'; use Scalar::Util 'blessed', 'weaken'; use base 'Moose::Meta::Mixin::AttributeCore', 'Class::MOP::Object'; __PACKAGE__->meta->add_attribute( 'metaclass' => ( reader => 'metaclass', Class::MOP::_definition_context(), ) ); __PACKAGE__->meta->add_attribute( 'associated_role' => ( reader => 'associated_role', Class::MOP::_definition_context(), ) ); __PACKAGE__->meta->add_attribute( '_original_role' => ( reader => '_original_role', Class::MOP::_definition_context(), ) ); __PACKAGE__->meta->add_attribute( 'is' => ( reader => 'is', Class::MOP::_definition_context(), ) ); __PACKAGE__->meta->add_attribute( 'original_options' => ( reader => 'original_options', Class::MOP::_definition_context(), ) ); sub new { my ( $class, $name, %options ) = @_; (defined $name) || confess "You must provide a name for the attribute"; my $role = delete $options{_original_role}; return bless { name => $name, original_options => \%options, _original_role => $role, %options, }, $class; } sub attach_to_role { my ( $self, $role ) = @_; ( blessed($role) && $role->isa('Moose::Meta::Role') ) || confess "You must pass a Moose::Meta::Role instance (or a subclass)"; weaken( $self->{'associated_role'} = $role ); } sub original_role { my $self = shift; return $self->_original_role || $self->associated_role; } sub attribute_for_class { my $self = shift; my $metaclass = $self->original_role->applied_attribute_metaclass; return $metaclass->interpolate_class_and_new( $self->name => %{ $self->original_options } ); } sub clone { my $self = shift; my $role = $self->original_role; return ( ref $self )->new( $self->name, %{ $self->original_options }, _original_role => $role, ); } sub is_same_as { my $self = shift; my $attr = shift; my $self_options = $self->original_options; my $other_options = $attr->original_options; return 0 unless ( join q{|}, sort keys %{$self_options} ) eq ( join q{|}, sort keys %{$other_options} ); for my $key ( keys %{$self_options} ) { return 0 if defined $self_options->{$key} && ! defined $other_options->{$key}; return 0 if ! defined $self_options->{$key} && defined $other_options->{$key}; next if all { ! defined } $self_options->{$key}, $other_options->{$key}; return 0 unless $self_options->{$key} eq $other_options->{$key}; } return 1; } 1; # ABSTRACT: The Moose attribute metaclass for Roles __END__ =pod =head1 NAME Moose::Meta::Role::Attribute - The Moose attribute metaclass for Roles =head1 VERSION version 2.1005 =head1 DESCRIPTION This class implements the API for attributes in roles. Attributes in roles are more like attribute prototypes than full blown attributes. While they are introspectable, they have very little behavior. =head1 METHODS This class provides the following methods: =over 4 =item B<< Moose::Meta::Role::Attribute->new(...) >> This method accepts all the options that would be passed to the constructor for L. =item B<< $attr->metaclass >> =item B<< $attr->is >> Returns the option as passed to the constructor. =item B<< $attr->associated_role >> Returns the L to which this attribute belongs, if any. =item B<< $attr->original_role >> Returns the L in which this attribute was first defined. This may not be the same as the value of C for attributes in a composite role, or when one role consumes other roles. =item B<< $attr->original_options >> Returns a hash reference of options passed to the constructor. This is used when creating a L object from this object. =item B<< $attr->attach_to_role($role) >> Attaches the attribute to the given L. =item B<< $attr->attribute_for_class($metaclass) >> Given an attribute metaclass name, this method calls C<< $metaclass->interpolate_class_and_new >> to construct an attribute object which can be added to a L. =item B<< $attr->clone >> Creates a new object identical to the object on which the method is called. =item B<< $attr->is_same_as($other_attr) >> Compares two role attributes and returns true if they are identical. =back In addition, this class implements all informational predicates implements by L (and L). =head1 BUGS See L for details on reporting bugs. =head1 AUTHOR Moose is maintained by the Moose Cabal, along with the help of many contributors. See L and L for details. =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2013 by Infinity Interactive, Inc.. This is free software; you can redistribute it and/or modify it under the same terms as the Perl 5 programming language system itself. =cut Composite.pm100644000767000024 1310712200352345 20276 0ustar00etherstaff000000000000Moose-2.1005/lib/Moose/Meta/Rolepackage Moose::Meta::Role::Composite; BEGIN { $Moose::Meta::Role::Composite::AUTHORITY = 'cpan:STEVAN'; } { $Moose::Meta::Role::Composite::VERSION = '2.1005'; } use strict; use warnings; use metaclass; use Class::Load qw(load_class); use Scalar::Util 'blessed'; use base 'Moose::Meta::Role'; # NOTE: # we need to override the ->name # method from Class::MOP::Package # since we don't have an actual # package for this. # - SL __PACKAGE__->meta->add_attribute('name' => ( reader => 'name', Class::MOP::_definition_context(), )); # NOTE: # Again, since we don't have a real # package to store our methods in, # we use a HASH ref instead. # - SL __PACKAGE__->meta->add_attribute('_methods' => ( reader => '_method_map', default => sub { {} }, Class::MOP::_definition_context(), )); __PACKAGE__->meta->add_attribute( 'application_role_summation_class', reader => 'application_role_summation_class', default => 'Moose::Meta::Role::Application::RoleSummation', Class::MOP::_definition_context(), ); sub new { my ($class, %params) = @_; # the roles param is required ... foreach ( @{$params{roles}} ) { unless ( $_->isa('Moose::Meta::Role') ) { require Moose; Moose->throw_error("The list of roles must be instances of Moose::Meta::Role, not $_"); } } my @composition_roles = map { $_->composition_class_roles } @{ $params{roles} }; if (@composition_roles) { my $meta = Moose::Meta::Class->create_anon_class( superclasses => [ $class ], roles => [ @composition_roles ], cache => 1, ); $class = $meta->name; } # and the name is created from the # roles if one has not been provided $params{name} ||= (join "|" => map { $_->name } @{$params{roles}}); $class->_new(\%params); } # This is largely a copy of what's in Moose::Meta::Role (itself # largely a copy of Class::MOP::Class). However, we can't actually # call add_package_symbol, because there's no package into which to # add the symbol. sub add_method { my ($self, $method_name, $method) = @_; unless ( defined $method_name && $method_name ) { Moose->throw_error("You must define a method name"); } my $body; if (blessed($method)) { $body = $method->body; if ($method->package_name ne $self->name) { $method = $method->clone( package_name => $self->name, name => $method_name ) if $method->can('clone'); } } else { $body = $method; $method = $self->wrap_method_body( body => $body, name => $method_name ); } $self->_method_map->{$method_name} = $method; } sub get_method_list { my $self = shift; return keys %{ $self->_method_map }; } sub _get_local_methods { my $self = shift; return values %{ $self->_method_map }; } sub has_method { my ($self, $method_name) = @_; return exists $self->_method_map->{$method_name}; } sub get_method { my ($self, $method_name) = @_; return $self->_method_map->{$method_name}; } sub apply_params { my ($self, $role_params) = @_; load_class($self->application_role_summation_class); $self->application_role_summation_class->new( role_params => $role_params, )->apply($self); return $self; } sub reinitialize { my ( $class, $old_meta, @args ) = @_; Moose->throw_error( 'Moose::Meta::Role::Composite instances can only be reinitialized from an existing metaclass instance' ) if !blessed $old_meta || !$old_meta->isa('Moose::Meta::Role::Composite'); my %existing_classes = map { $_ => $old_meta->$_() } qw( application_role_summation_class ); return $old_meta->meta->clone_object( $old_meta, %existing_classes, @args ); } 1; # ABSTRACT: An object to represent the set of roles __END__ =pod =head1 NAME Moose::Meta::Role::Composite - An object to represent the set of roles =head1 VERSION version 2.1005 =head1 DESCRIPTION A composite is a role that consists of a set of two or more roles. The API of a composite role is almost identical to that of a regular role. =head1 INHERITANCE C is a subclass of L. =head2 METHODS =over 4 =item B<< Moose::Meta::Role::Composite->new(%options) >> This returns a new composite role object. It accepts the same options as its parent class, with a few changes: =over 8 =item * roles This option is an array reference containing a list of L object. This is a required option. =item * name If a name is not given, one is generated from the roles provided. =item * apply_params(\%role_params) Creates a new RoleSummation role application with C<%role_params> and applies the composite role to it. The RoleSummation role application class used is determined by the composite role's C attribute. =item * reinitialize($metaclass) Like C<< Class::MOP::Package->reinitialize >>, but doesn't allow passing a string with the package name, as there is no real package for composite roles. =back =back =head1 BUGS See L for details on reporting bugs. =head1 AUTHOR Moose is maintained by the Moose Cabal, along with the help of many contributors. See L and L for details. =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2013 by Infinity Interactive, Inc.. This is free software; you can redistribute it and/or modify it under the same terms as the Perl 5 programming language system itself. =cut accessor_inlining.t100644000767000024 107012200352345 20642 0ustar00etherstaff000000000000Moose-2.1005/t/attributes#!/usr/bin/env perl use strict; use warnings; use Test::More; my $called; { package Foo::Meta::Instance; use Moose::Role; sub is_inlinable { 0 } after get_slot_value => sub { $called++ }; } { package Foo; use Moose; Moose::Util::MetaRole::apply_metaroles( for => __PACKAGE__, class_metaroles => { instance => ['Foo::Meta::Instance'], }, ); has foo => (is => 'ro'); } my $foo = Foo->new(foo => 1); is($foo->foo, 1, "got the right value"); is($called, 1, "reader was called"); done_testing; coerce_without_coercion.t100644000767000024 174512200352345 20640 0ustar00etherstaff000000000000Moose-2.1005/t/bugsuse strict; use warnings; use Test::More; use Test::Fatal; use Test::Moose; { package Foo; use Moose::Deprecated -api_version => '1.07'; use Moose; has x => ( is => 'rw', isa => 'HashRef', coerce => 1, ); } with_immutable { is( exception { Foo->new( x => {} ) }, undef, 'Setting coerce => 1 without a coercion on the type does not cause an error in the constructor' ); is( exception { Foo->new->x( {} ) }, undef, 'Setting coerce => 1 without a coercion on the type does not cause an error when setting the attribut' ); like( exception { Foo->new( x => 42 ) }, qr/\QAttribute (x) does not pass the type constraint because/, 'Attempting to provide an invalid value to the constructor for this attr still fails' ); like( exception { Foo->new->x(42) }, qr/\QAttribute (x) does not pass the type constraint because/, 'Attempting to provide an invalid value to the accessor for this attr still fails' ); } 'Foo'; done_testing; DEMOLISHALL_shortcutted.t100644000767000024 143212200352345 20112 0ustar00etherstaff000000000000Moose-2.1005/t/bugs## This test ensures that sub DEMOLISHALL fires even if there is no sub DEMOLISH ## Currently fails because of a bad optimization in DESTROY ## Feb 12, 2009 -- Evan Carroll me@evancarroll.com package Role::DemolishAll; use Moose::Role; our $ok = 0; sub BUILD { $ok = 0 }; after 'DEMOLISHALL' => sub { $Role::DemolishAll::ok++ }; package DemolishAll::WithoutDemolish; use Moose; with 'Role::DemolishAll'; package DemolishAll::WithDemolish; use Moose; with 'Role::DemolishAll'; sub DEMOLISH {}; package main; use Test::More; my $m = DemolishAll::WithDemolish->new; undef $m; is ( $Role::DemolishAll::ok, 1, 'DemolishAll w/ explicit DEMOLISH sub' ); $m = DemolishAll::WithoutDemolish->new; undef $m; is ( $Role::DemolishAll::ok, 1, 'DemolishAll wo/ explicit DEMOLISH sub' ); done_testing; add_attribute_alternate.t100644000767000024 504512200352345 20601 0ustar00etherstaff000000000000Moose-2.1005/t/cmopuse strict; use warnings; use Test::More; use Test::Fatal; use Class::MOP; { package Point; use metaclass; Point->meta->add_attribute('x' => ( reader => 'x', init_arg => 'x' )); Point->meta->add_attribute('y' => ( accessor => 'y', init_arg => 'y' )); sub new { my $class = shift; bless $class->meta->new_object(@_) => $class; } sub clear { my $self = shift; $self->{'x'} = 0; $self->{'y'} = 0; } package Point3D; our @ISA = ('Point'); Point3D->meta->add_attribute('z' => ( default => 123 )); sub clear { my $self = shift; $self->{'z'} = 0; $self->SUPER::clear(); } } isa_ok(Point->meta, 'Class::MOP::Class'); isa_ok(Point3D->meta, 'Class::MOP::Class'); # ... test the classes themselves my $point = Point->new('x' => 2, 'y' => 3); isa_ok($point, 'Point'); can_ok($point, 'x'); can_ok($point, 'y'); can_ok($point, 'clear'); { my $meta = $point->meta; is($meta, Point->meta(), '... got the meta from the instance too'); } is($point->y, 3, '... the y attribute was initialized correctly through the metaobject'); $point->y(42); is($point->y, 42, '... the y attribute was set properly with the accessor'); is($point->x, 2, '... the x attribute was initialized correctly through the metaobject'); isnt( exception { $point->x(42); }, undef, '... cannot write to a read-only accessor' ); is($point->x, 2, '... the x attribute was not altered'); $point->clear(); is($point->y, 0, '... the y attribute was cleared correctly'); is($point->x, 0, '... the x attribute was cleared correctly'); my $point3d = Point3D->new('x' => 1, 'y' => 2, 'z' => 3); isa_ok($point3d, 'Point3D'); isa_ok($point3d, 'Point'); { my $meta = $point3d->meta; is($meta, Point3D->meta(), '... got the meta from the instance too'); } can_ok($point3d, 'x'); can_ok($point3d, 'y'); can_ok($point3d, 'clear'); is($point3d->x, 1, '... the x attribute was initialized correctly through the metaobject'); is($point3d->y, 2, '... the y attribute was initialized correctly through the metaobject'); is($point3d->{'z'}, 3, '... the z attribute was initialized correctly through the metaobject'); { my $point3d = Point3D->new(); isa_ok($point3d, 'Point3D'); is($point3d->x, undef, '... the x attribute was not initialized'); is($point3d->y, undef, '... the y attribute was not initialized'); is($point3d->{'z'}, 123, '... the z attribute was initialized correctly through the metaobject'); } done_testing; attribute_introspection.t100644000767000024 626712200352345 20721 0ustar00etherstaff000000000000Moose-2.1005/t/cmopuse strict; use warnings; use Test::More; use Test::Fatal; use Class::MOP; { my $attr = Class::MOP::Attribute->new('$test'); is( $attr->meta, Class::MOP::Attribute->meta, '... instance and class both lead to the same meta' ); } { my $meta = Class::MOP::Attribute->meta(); isa_ok( $meta, 'Class::MOP::Class' ); my @methods = qw( new clone initialize_instance_slot _set_initial_slot_value _make_initializer_writer_callback name has_accessor accessor has_writer writer has_write_method get_write_method get_write_method_ref has_reader reader has_read_method get_read_method get_read_method_ref has_predicate predicate has_clearer clearer has_builder builder has_init_arg init_arg has_default default is_default_a_coderef has_initializer initializer has_insertion_order insertion_order _set_insertion_order definition_context slots get_value set_value get_raw_value set_raw_value set_initial_value has_value clear_value associated_class attach_to_class detach_from_class accessor_metaclass associated_methods associate_method _process_accessors _accessor_description install_accessors remove_accessors _inline_get_value _inline_set_value _inline_has_value _inline_clear_value _inline_instance_get _inline_instance_set _inline_instance_has _inline_instance_clear _new ); is_deeply( [ sort Class::MOP::Mixin::AttributeCore->meta->get_method_list, $meta->get_method_list ], [ sort @methods ], '... our method list matches' ); foreach my $method_name (@methods) { ok( $meta->find_method_by_name($method_name), '... Class::MOP::Attribute->find_method_by_name(' . $method_name . ')' ); } my @attributes = ( 'name', 'accessor', 'reader', 'writer', 'predicate', 'clearer', 'builder', 'init_arg', 'initializer', 'definition_context', 'default', 'associated_class', 'associated_methods', 'insertion_order', ); is_deeply( [ sort Class::MOP::Mixin::AttributeCore->meta->get_attribute_list, $meta->get_attribute_list ], [ sort @attributes ], '... our attribute list matches' ); foreach my $attribute_name (@attributes) { ok( $meta->find_attribute_by_name($attribute_name), '... Class::MOP::Attribute->find_attribute_by_name(' . $attribute_name . ')' ); } # We could add some tests here to make sure that # the attribute have the appropriate # accessor/reader/writer/predicate combinations, # but that is getting a little excessive so I # wont worry about it for now. Maybe if I get # bored I will do it. } done_testing; metaclass_loads_classes.t100644000767000024 220612200352345 20576 0ustar00etherstaff000000000000Moose-2.1005/t/cmopuse strict; use warnings; use FindBin; use File::Spec::Functions; use Test::More; use Class::Load qw(is_class_loaded); use lib catdir($FindBin::Bin, 'lib'); { package Foo; use strict; use warnings; use metaclass 'MyMetaClass' => ( 'attribute_metaclass' => 'MyMetaClass::Attribute', 'instance_metaclass' => 'MyMetaClass::Instance', 'method_metaclass' => 'MyMetaClass::Method', 'random_metaclass' => 'MyMetaClass::Random', ); } my $meta = Foo->meta; isa_ok($meta, 'MyMetaClass', '... Correct metaclass'); ok(is_class_loaded('MyMetaClass'), '... metaclass loaded'); is($meta->attribute_metaclass, 'MyMetaClass::Attribute', '... Correct attribute metaclass'); ok(is_class_loaded('MyMetaClass::Attribute'), '... attribute metaclass loaded'); is($meta->instance_metaclass, 'MyMetaClass::Instance', '... Correct instance metaclass'); ok(is_class_loaded('MyMetaClass::Instance'), '... instance metaclass loaded'); is($meta->method_metaclass, 'MyMetaClass::Method', '... Correct method metaclass'); ok(is_class_loaded('MyMetaClass::Method'), '... method metaclass loaded'); done_testing; MyMetaClass000755000767000024 012200352345 16326 5ustar00etherstaff000000000000Moose-2.1005/t/cmop/libMethod.pm100644000767000024 13512200352345 20223 0ustar00etherstaff000000000000Moose-2.1005/t/cmop/lib/MyMetaClass package MyMetaClass::Method; use strict; use warnings; use base 'Class::MOP::Method'; 1; Random.pm100644000767000024 7512200352345 20206 0ustar00etherstaff000000000000Moose-2.1005/t/cmop/lib/MyMetaClass package MyMetaClass::Random; use strict; use warnings; 1; module_refresh_compat.t100644000767000024 366412200352345 20627 0ustar00etherstaff000000000000Moose-2.1005/t/compat#!/usr/bin/perl use strict; use warnings; use lib 't/lib', 'lib'; use Test::More; use Test::Fatal; use File::Spec; use File::Temp 'tempdir'; use Test::Requires { 'Module::Refresh' => '0.01', # skip all if not installed }; =pod First lets test some of our simple example modules ... =cut my @modules = qw[Foo Bar MyMooseA MyMooseB MyMooseObject]; do { use_ok($_); is($_->meta->name, $_, '... initialized the meta correctly'); is( exception { Module::Refresh->new->refresh_module($_ . '.pm') }, undef, '... successfully refreshed ' ); } foreach @modules; =pod Now, lets try something a little trickier and actually change the module itself. =cut my $dir = tempdir( "MooseTest-XXXXX", CLEANUP => 1, TMPDIR => 1 ); push @INC, $dir; my $test_module_file = File::Spec->catdir($dir, 'TestBaz.pm'); my $test_module_source_1 = q| package TestBaz; use Moose; has 'foo' => (is => 'ro', isa => 'Int'); 1; |; my $test_module_source_2 = q| package TestBaz; use Moose; extends 'Foo'; has 'foo' => (is => 'rw', isa => 'Int'); 1; |; { open FILE, ">", $test_module_file || die "Could not open $test_module_file because $!"; print FILE $test_module_source_1; close FILE; } use_ok('TestBaz'); is(TestBaz->meta->name, 'TestBaz', '... initialized the meta correctly'); ok(TestBaz->meta->has_attribute('foo'), '... it has the foo attribute as well'); ok(!TestBaz->isa('Foo'), '... TestBaz is not a Foo'); { open FILE, ">", $test_module_file || die "Could not open $test_module_file because $!"; print FILE $test_module_source_2; close FILE; } is( exception { Module::Refresh->new->refresh_module('TestBaz.pm') }, undef, '... successfully refreshed ' ); is(TestBaz->meta->name, 'TestBaz', '... initialized the meta correctly'); ok(TestBaz->meta->has_attribute('foo'), '... it has the foo attribute as well'); ok(TestBaz->isa('Foo'), '... TestBaz is a Foo'); unlink $test_module_file; done_testing; record_set_iterator.t100644000767000024 532012200352345 20645 0ustar00etherstaff000000000000Moose-2.1005/t/examples#!/usr/bin/perl use strict; use warnings; use Test::More; { package Record; use Moose; has 'first_name' => (is => 'ro', isa => 'Str'); has 'last_name' => (is => 'ro', isa => 'Str'); package RecordSet; use Moose; has 'data' => ( is => 'ro', isa => 'ArrayRef[Record]', default => sub { [] }, ); has 'index' => ( is => 'rw', isa => 'Int', default => sub { 0 }, ); sub next { my $self = shift; my $i = $self->index; $self->index($i + 1); return $self->data->[$i]; } package RecordSetIterator; use Moose; has 'record_set' => ( is => 'rw', isa => 'RecordSet', ); # list the fields you want to # fetch from the current record my @fields = Record->meta->get_attribute_list; has 'current_record' => ( is => 'rw', isa => 'Record', lazy => 1, default => sub { my $self = shift; $self->record_set->next() # grab the first one }, trigger => sub { my $self = shift; # whenever this attribute is # updated, it will clear all # the fields for you. $self->$_() for map { '_clear_' . $_ } @fields; } ); # define the attributes # for all the fields. for my $field (@fields) { has $field => ( is => 'ro', isa => 'Any', lazy => 1, default => sub { my $self = shift; # fetch the value from # the current record $self->current_record->$field(); }, # make sure they have a clearer .. clearer => ('_clear_' . $field) ); } sub get_next_record { my $self = shift; $self->current_record($self->record_set->next()); } } my $rs = RecordSet->new( data => [ Record->new(first_name => 'Bill', last_name => 'Smith'), Record->new(first_name => 'Bob', last_name => 'Jones'), Record->new(first_name => 'Jim', last_name => 'Johnson'), ] ); isa_ok($rs, 'RecordSet'); my $rsi = RecordSetIterator->new(record_set => $rs); isa_ok($rsi, 'RecordSetIterator'); is($rsi->first_name, 'Bill', '... got the right first name'); is($rsi->last_name, 'Smith', '... got the right last name'); $rsi->get_next_record; is($rsi->first_name, 'Bob', '... got the right first name'); is($rsi->last_name, 'Jones', '... got the right last name'); $rsi->get_next_record; is($rsi->first_name, 'Jim', '... got the right first name'); is($rsi->last_name, 'Johnson', '... got the right last name'); done_testing; definition_context.t100644000767000024 373412200352345 20647 0ustar00etherstaff000000000000Moose-2.1005/t/immutable#!/usr/bin/env perl use strict; use warnings; use Test::More; use Test::Fatal; { use Moose::Util::TypeConstraints; use Carp 'confess'; subtype 'Death', as 'Int', where { $_ == 1 }; coerce 'Death', from 'Any', via { confess }; } { my ($attr_foo_line, $attr_bar_line, $ctor_line); { package Foo; use Moose; has foo => ( is => 'rw', isa => 'Death', coerce => 1, ); $attr_foo_line = __LINE__ - 5; has bar => ( accessor => 'baz', isa => 'Death', coerce => 1, ); $attr_bar_line = __LINE__ - 5; __PACKAGE__->meta->make_immutable; $ctor_line = __LINE__ - 1; } like( exception { Foo->new(foo => 2) }, qr/called at constructor Foo::new \(defined at $0 line $ctor_line\)/, "got definition context for the constructor" ); like( exception { my $f = Foo->new(foo => 1); $f->foo(2) }, qr/called at accessor Foo::foo \(defined at $0 line $attr_foo_line\)/, "got definition context for the accessor" ); like( exception { my $f = Foo->new(foo => 1); $f->baz(2) }, qr/called at accessor Foo::baz of attribute bar \(defined at $0 line $attr_bar_line\)/, "got definition context for the accessor" ); } { my ($dtor_line); { package Bar; use Moose; # just dying here won't work, because perl's exception handling is # terrible sub DEMOLISH { try { confess } catch { warn $_ } } __PACKAGE__->meta->make_immutable; $dtor_line = __LINE__ - 1; } { my $warning = ''; local $SIG{__WARN__} = sub { $warning .= $_[0] }; { Bar->new } like( $warning, qr/called at destructor Bar::DESTROY \(defined at $0 line $dtor_line\)/, "got definition context for the destructor" ); } } done_testing; metaclass_compat.t100644000767000024 2153512200352345 20636 0ustar00etherstaff000000000000Moose-2.1005/t/metaclasses#!/usr/bin/env perl use strict; use warnings; use lib 't/lib'; use Test::More; use Test::Fatal; our $called = 0; { package Foo::Trait::Class; use Moose::Role; around _inline_BUILDALL => sub { my $orig = shift; my $self = shift; return ( $self->$orig(@_), '$::called++;' ); } } { package Foo; use Moose; Moose::Util::MetaRole::apply_metaroles( for => __PACKAGE__, class_metaroles => { class => ['Foo::Trait::Class'], } ); } Foo->new; is($called, 0, "no calls before inlining"); Foo->meta->make_immutable; Foo->new; is($called, 1, "inlined constructor has trait modifications"); ok(Foo->meta->meta->does_role('Foo::Trait::Class'), "class has correct traits"); { package Foo::Sub; use Moose; extends 'Foo'; } $called = 0; Foo::Sub->new; is($called, 0, "no calls before inlining"); Foo::Sub->meta->make_immutable; Foo::Sub->new; is($called, 1, "inherits trait properly"); ok(Foo::Sub->meta->meta->can('does_role') && Foo::Sub->meta->meta->does_role('Foo::Trait::Class'), "subclass inherits traits"); { package Foo2::Role; use Moose::Role; } { package Foo2; use Moose -traits => ['Foo2::Role']; } { package Bar2; use Moose; } { package Baz2; use Moose; my $meta = __PACKAGE__->meta; ::is( ::exception { $meta->superclasses('Foo2') }, undef, "can set superclasses once" ); ::isa_ok($meta, Foo2->meta->meta->name); ::is( ::exception { $meta->superclasses('Bar2') }, undef, "can still set superclasses" ); ::isa_ok($meta, Bar2->meta->meta->name); ::is_deeply([sort map { $_->name } $meta->meta->calculate_all_roles_with_inheritance], ['Foo2::Role'], "still have the role attached"); ::ok(!$meta->is_immutable, "immutable superclass doesn't make this class immutable"); ::is( ::exception { $meta->make_immutable }, undef, "can still make immutable" ); } { package Foo3::Role; use Moose::Role; } { package Bar3; use Moose -traits => ['Foo3::Role']; } { package Baz3; use Moose -traits => ['Foo3::Role']; my $meta = __PACKAGE__->meta; ::is( ::exception { $meta->superclasses('Foo2') }, undef, "can set superclasses once" ); ::isa_ok($meta, Foo2->meta->meta->name); ::is_deeply([sort map { $_->name } $meta->meta->calculate_all_roles_with_inheritance], ['Foo2::Role', 'Foo3::Role'], "reconciled roles correctly"); ::is( ::exception { $meta->superclasses('Bar3') }, undef, "can still set superclasses" ); ::isa_ok($meta, Bar3->meta->meta->name); ::is_deeply([sort map { $_->name } $meta->meta->calculate_all_roles_with_inheritance], ['Foo2::Role', 'Foo3::Role'], "roles still the same"); ::ok(!$meta->is_immutable, "immutable superclass doesn't make this class immutable"); ::is( ::exception { $meta->make_immutable }, undef, "can still make immutable" ); } { package Quux3; use Moose; } { package Quuux3; use Moose -traits => ['Foo3::Role']; my $meta = __PACKAGE__->meta; ::is( ::exception { $meta->superclasses('Foo2') }, undef, "can set superclasses once" ); ::isa_ok($meta, Foo2->meta->meta->name); ::is_deeply([sort map { $_->name } $meta->meta->calculate_all_roles_with_inheritance], ['Foo2::Role', 'Foo3::Role'], "reconciled roles correctly"); ::is( ::exception { $meta->superclasses('Quux3') }, undef, "can still set superclasses" ); ::isa_ok($meta, Quux3->meta->meta->name); ::is_deeply([sort map { $_->name } $meta->meta->calculate_all_roles_with_inheritance], ['Foo2::Role', 'Foo3::Role'], "roles still the same"); ::ok(!$meta->is_immutable, "immutable superclass doesn't make this class immutable"); ::is( ::exception { $meta->make_immutable }, undef, "can still make immutable" ); } { package Foo4::Role; use Moose::Role; } { package Foo4; use Moose -traits => ['Foo4::Role']; __PACKAGE__->meta->make_immutable; } { package Bar4; use Moose; } { package Baz4; use Moose; my $meta = __PACKAGE__->meta; ::is( ::exception { $meta->superclasses('Foo4') }, undef, "can set superclasses once" ); ::isa_ok($meta, Foo4->meta->_get_mutable_metaclass_name); ::is( ::exception { $meta->superclasses('Bar4') }, undef, "can still set superclasses" ); ::isa_ok($meta, Bar4->meta->meta->name); ::is_deeply([sort map { $_->name } $meta->meta->calculate_all_roles_with_inheritance], ['Foo4::Role'], "still have the role attached"); ::ok(!$meta->is_immutable, "immutable superclass doesn't make this class immutable"); ::is( ::exception { $meta->make_immutable }, undef, "can still make immutable" ); } { package Foo5::Role; use Moose::Role; } { package Bar5; use Moose -traits => ['Foo5::Role']; } { package Baz5; use Moose -traits => ['Foo5::Role']; my $meta = __PACKAGE__->meta; ::is( ::exception { $meta->superclasses('Foo4') }, undef, "can set superclasses once" ); ::isa_ok($meta, Foo4->meta->_get_mutable_metaclass_name); ::is_deeply([sort map { $_->name } $meta->meta->calculate_all_roles_with_inheritance], ['Foo4::Role', 'Foo5::Role'], "reconciled roles correctly"); ::is( ::exception { $meta->superclasses('Bar5') }, undef, "can still set superclasses" ); ::isa_ok($meta, Bar5->meta->meta->name); ::is_deeply([sort map { $_->name } $meta->meta->calculate_all_roles_with_inheritance], ['Foo4::Role', 'Foo5::Role'], "roles still the same"); ::ok(!$meta->is_immutable, "immutable superclass doesn't make this class immutable"); ::is( ::exception { $meta->make_immutable }, undef, "can still make immutable" ); } { package Quux5; use Moose; } { package Quuux5; use Moose -traits => ['Foo5::Role']; my $meta = __PACKAGE__->meta; ::is( ::exception { $meta->superclasses('Foo4') }, undef, "can set superclasses once" ); ::isa_ok($meta, Foo4->meta->_get_mutable_metaclass_name); ::is_deeply([sort map { $_->name } $meta->meta->calculate_all_roles_with_inheritance], ['Foo4::Role', 'Foo5::Role'], "reconciled roles correctly"); ::is( ::exception { $meta->superclasses('Quux5') }, undef, "can still set superclasses" ); ::isa_ok($meta, Quux5->meta->meta->name); ::is_deeply([sort map { $_->name } $meta->meta->calculate_all_roles_with_inheritance], ['Foo4::Role', 'Foo5::Role'], "roles still the same"); ::ok(!$meta->is_immutable, "immutable superclass doesn't make this class immutable"); ::is( ::exception { $meta->make_immutable }, undef, "can still make immutable" ); } { package Foo5::Meta::Role; use Moose::Role; } { package Foo5::SuperClass::WithMetaRole; use Moose -traits =>'Foo5::Meta::Role'; } { package Foo5::SuperClass::After::Attribute; use Moose; } { package Foo5; use Moose; my @superclasses = ('Foo5::SuperClass::WithMetaRole'); extends @superclasses; has an_attribute_generating_methods => ( is => 'ro' ); push(@superclasses, 'Foo5::SuperClass::After::Attribute'); ::is( ::exception { extends @superclasses; }, undef, 'MI extends after_generated_methods with metaclass roles' ); ::is( ::exception { extends reverse @superclasses; }, undef, 'MI extends after_generated_methods with metaclass roles (reverse)' ); } { package Foo6::Meta::Role; use Moose::Role; } { package Foo6::SuperClass::WithMetaRole; use Moose -traits =>'Foo6::Meta::Role'; } { package Foo6::Meta::OtherRole; use Moose::Role; } { package Foo6::SuperClass::After::Attribute; use Moose -traits =>'Foo6::Meta::OtherRole'; } { package Foo6; use Moose; my @superclasses = ('Foo6::SuperClass::WithMetaRole'); extends @superclasses; has an_attribute_generating_methods => ( is => 'ro' ); push(@superclasses, 'Foo6::SuperClass::After::Attribute'); ::like( ::exception { extends @superclasses; }, qr/compat.*pristine/, 'unsafe MI extends after_generated_methods with metaclass roles' ); ::like( ::exception { extends reverse @superclasses; }, qr/compat.*pristine/, 'unsafe MI extends after_generated_methods with metaclass roles (reverse)' ); } { package Foo7::Meta::Trait; use Moose::Role; } { package Foo7; use Moose -traits => ['Foo7::Meta::Trait']; } { package Bar7; # in an external file use Moose -traits => ['Bar7::Meta::Trait']; ::is( ::exception { extends 'Foo7' }, undef, "role reconciliation works" ); } { package Bar72; # in an external file use Moose -traits => ['Bar7::Meta::Trait2']; ::is( ::exception { extends 'Foo7' }, undef, "role reconciliation works" ); } done_testing; metaclass_traits.t100644000767000024 1141212200352345 20652 0ustar00etherstaff000000000000Moose-2.1005/t/metaclasses#!/usr/bin/perl use strict; use warnings; use lib 't/lib', 'lib'; use Test::More; use Test::Fatal; { package My::SimpleTrait; use Moose::Role; sub simple { return 5 } } { package Foo; use Moose -traits => [ 'My::SimpleTrait' ]; } can_ok( Foo->meta(), 'simple' ); is( Foo->meta()->simple(), 5, 'Foo->meta()->simple() returns expected value' ); { package Bar; use Moose -traits => 'My::SimpleTrait'; } can_ok( Bar->meta(), 'simple' ); is( Bar->meta()->simple(), 5, 'Foo->meta()->simple() returns expected value' ); { package My::SimpleTrait2; use Moose::Role; # This needs to happen at compile time so it happens before we # apply traits to Bar BEGIN { has 'attr' => ( is => 'ro', default => 'something', ); } sub simple { return 5 } } { package Bar; use Moose -traits => [ 'My::SimpleTrait2' ]; } can_ok( Bar->meta(), 'simple' ); is( Bar->meta()->simple(), 5, 'Bar->meta()->simple() returns expected value' ); can_ok( Bar->meta(), 'attr' ); is( Bar->meta()->attr(), 'something', 'Bar->meta()->attr() returns expected value' ); { package My::SimpleTrait3; use Moose::Role; BEGIN { has 'attr2' => ( is => 'ro', default => 'something', ); } sub simple2 { return 55 } } { package Baz; use Moose -traits => [ 'My::SimpleTrait2', 'My::SimpleTrait3' ]; } can_ok( Baz->meta(), 'simple' ); is( Baz->meta()->simple(), 5, 'Baz->meta()->simple() returns expected value' ); can_ok( Baz->meta(), 'attr' ); is( Baz->meta()->attr(), 'something', 'Baz->meta()->attr() returns expected value' ); can_ok( Baz->meta(), 'simple2' ); is( Baz->meta()->simple2(), 55, 'Baz->meta()->simple2() returns expected value' ); can_ok( Baz->meta(), 'attr2' ); is( Baz->meta()->attr2(), 'something', 'Baz->meta()->attr2() returns expected value' ); { package My::Trait::AlwaysRO; use Moose::Role; around '_process_new_attribute', '_process_inherited_attribute' => sub { my $orig = shift; my ( $self, $name, %args ) = @_; $args{is} = 'ro'; return $self->$orig( $name, %args ); }; } { package Quux; use Moose -traits => [ 'My::Trait::AlwaysRO' ]; has 'size' => ( is => 'rw', isa => 'Int', ); } ok( Quux->meta()->has_attribute('size'), 'Quux has size attribute' ); ok( ! Quux->meta()->get_attribute('size')->writer(), 'size attribute does not have a writer' ); { package My::Class::Whatever; use Moose::Role; sub whatever { 42 } package Moose::Meta::Class::Custom::Trait::Whatever; sub register_implementation { return 'My::Class::Whatever'; } } { package RanOutOfNames; use Moose -traits => [ 'Whatever' ]; } ok( RanOutOfNames->meta()->meta()->has_method('whatever'), 'RanOutOfNames->meta() has whatever method' ); { package Role::Foo; use Moose::Role -traits => [ 'My::SimpleTrait' ]; } can_ok( Role::Foo->meta(), 'simple' ); is( Role::Foo->meta()->simple(), 5, 'Role::Foo->meta()->simple() returns expected value' ); { require Moose::Util::TypeConstraints; like( exception { Moose::Util::TypeConstraints->import( -traits => 'My::SimpleTrait' ); }, qr/does not have an init_meta/, 'cannot provide -traits to an exporting module that does not init_meta' ); } { package Foo::Subclass; use Moose -traits => [ 'My::SimpleTrait3' ]; extends 'Foo'; } can_ok( Foo::Subclass->meta(), 'simple' ); is( Foo::Subclass->meta()->simple(), 5, 'Foo::Subclass->meta()->simple() returns expected value' ); is( Foo::Subclass->meta()->simple2(), 55, 'Foo::Subclass->meta()->simple2() returns expected value' ); can_ok( Foo::Subclass->meta(), 'attr2' ); is( Foo::Subclass->meta()->attr2(), 'something', 'Foo::Subclass->meta()->attr2() returns expected value' ); { package Class::WithAlreadyPresentTrait; use Moose -traits => 'My::SimpleTrait'; has an_attr => ( is => 'ro' ); } is( exception { my $instance = Class::WithAlreadyPresentTrait->new( an_attr => 'value' ); is( $instance->an_attr, 'value', 'Can get value' ); }, undef, 'Can create instance and access attributes' ); { package Class::WhichLoadsATraitFromDisk; # Any role you like here, the only important bit is that it gets # loaded from disk and has not already been defined. use Moose -traits => 'Role::Parent'; has an_attr => ( is => 'ro' ); } is( exception { my $instance = Class::WhichLoadsATraitFromDisk->new( an_attr => 'value' ); is( $instance->an_attr, 'value', 'Can get value' ); }, undef, 'Can create instance and access attributes' ); done_testing; metarole_on_anon.t100644000767000024 163512200352345 20615 0ustar00etherstaff000000000000Moose-2.1005/t/metaclassesuse strict; use warnings; use Test::More; use Moose (); use Moose::Meta::Class; use Moose::Util::MetaRole; { package Foo; use Moose; } { package Role::Bar; use Moose::Role; } my $anon_name; { my $anon_class = Moose::Meta::Class->create_anon_class( superclasses => ['Foo'], cache => 1, ); $anon_name = $anon_class->name; ok( $anon_name->meta, 'anon class has a metaclass' ); } ok( $anon_name->meta, 'cached anon class still has a metaclass after \$anon_class goes out of scope' ); Moose::Util::MetaRole::apply_metaroles( for => $anon_name, class_metaroles => { class => ['Role::Bar'], }, ); BAIL_OUT('Cannot continue if the anon class does not have a metaclass') unless $anon_name->can('meta'); my $meta = $anon_name->meta; ok( $meta, 'cached anon class still has a metaclass applying a metarole' ); done_testing; new_object_BUILD.t100644000767000024 45512200352345 20313 0ustar00etherstaff000000000000Moose-2.1005/t/metaclasses#!/usr/bin/env perl use strict; use warnings; use Test::More; my $called; { package Foo; use Moose; sub BUILD { $called++ } } Foo->new; is($called, 1, "BUILD called from ->new"); $called = 0; Foo->meta->new_object; is($called, 1, "BUILD called from ->meta->new_object"); done_testing; array_subtypes.t100644000767000024 1357512200352345 20750 0ustar00etherstaff000000000000Moose-2.1005/t/native_traits#!/usr/bin/env perl use strict; use warnings; use Test::More; use Test::Fatal; { use Moose::Util::TypeConstraints; use List::Util qw(sum); subtype 'A1', as 'ArrayRef[Int]'; subtype 'A2', as 'ArrayRef', where { @$_ < 2 }; subtype 'A3', as 'ArrayRef[Int]', where { ( sum(@$_) || 0 ) < 5 }; subtype 'A5', as 'ArrayRef'; coerce 'A5', from 'Str', via { [ $_ ] }; no Moose::Util::TypeConstraints; } { package Foo; use Moose; has array => ( traits => ['Array'], is => 'rw', isa => 'ArrayRef', handles => { push_array => 'push', }, ); has array_int => ( traits => ['Array'], is => 'rw', isa => 'ArrayRef[Int]', handles => { push_array_int => 'push', }, ); has a1 => ( traits => ['Array'], is => 'rw', isa => 'A1', handles => { push_a1 => 'push', }, ); has a2 => ( traits => ['Array'], is => 'rw', isa => 'A2', handles => { push_a2 => 'push', }, ); has a3 => ( traits => ['Array'], is => 'rw', isa => 'A3', handles => { push_a3 => 'push', }, ); has a4 => ( traits => ['Array'], is => 'rw', isa => 'ArrayRef', lazy => 1, default => 'invalid', clearer => '_clear_a4', handles => { get_a4 => 'get', push_a4 => 'push', accessor_a4 => 'accessor', }, ); has a5 => ( traits => ['Array'], is => 'rw', isa => 'A5', coerce => 1, lazy => 1, default => 'invalid', clearer => '_clear_a5', handles => { get_a5 => 'get', push_a5 => 'push', accessor_a5 => 'accessor', }, ); } my $foo = Foo->new; { $foo->array( [] ); is_deeply( $foo->array, [], "array - correct contents" ); $foo->push_array('foo'); is_deeply( $foo->array, ['foo'], "array - correct contents" ); } { $foo->array_int( [] ); is_deeply( $foo->array_int, [], "array_int - correct contents" ); isnt( exception { $foo->push_array_int('foo') }, undef, "array_int - can't push wrong type" ); is_deeply( $foo->array_int, [], "array_int - correct contents" ); $foo->push_array_int(1); is_deeply( $foo->array_int, [1], "array_int - correct contents" ); } { isnt( exception { $foo->push_a1('foo') }, undef, "a1 - can't push onto undef" ); $foo->a1( [] ); is_deeply( $foo->a1, [], "a1 - correct contents" ); isnt( exception { $foo->push_a1('foo') }, undef, "a1 - can't push wrong type" ); is_deeply( $foo->a1, [], "a1 - correct contents" ); $foo->push_a1(1); is_deeply( $foo->a1, [1], "a1 - correct contents" ); } { isnt( exception { $foo->push_a2('foo') }, undef, "a2 - can't push onto undef" ); $foo->a2( [] ); is_deeply( $foo->a2, [], "a2 - correct contents" ); $foo->push_a2('foo'); is_deeply( $foo->a2, ['foo'], "a2 - correct contents" ); isnt( exception { $foo->push_a2('bar') }, undef, "a2 - can't push more than one element" ); is_deeply( $foo->a2, ['foo'], "a2 - correct contents" ); } { isnt( exception { $foo->push_a3(1) }, undef, "a3 - can't push onto undef" ); $foo->a3( [] ); is_deeply( $foo->a3, [], "a3 - correct contents" ); isnt( exception { $foo->push_a3('foo') }, undef, "a3 - can't push non-int" ); isnt( exception { $foo->push_a3(100) }, undef, "a3 - can't violate overall type constraint" ); is_deeply( $foo->a3, [], "a3 - correct contents" ); $foo->push_a3(1); is_deeply( $foo->a3, [1], "a3 - correct contents" ); isnt( exception { $foo->push_a3(100) }, undef, "a3 - can't violate overall type constraint" ); is_deeply( $foo->a3, [1], "a3 - correct contents" ); $foo->push_a3(3); is_deeply( $foo->a3, [ 1, 3 ], "a3 - correct contents" ); } { my $expect = qr/\QAttribute (a4) does not pass the type constraint because: Validation failed for 'ArrayRef' with value \E.*invalid.*/; like( exception { $foo->accessor_a4(0); }, $expect, 'invalid default is caught when trying to read via accessor' ); like( exception { $foo->accessor_a4( 0 => 42 ); }, $expect, 'invalid default is caught when trying to write via accessor' ); like( exception { $foo->push_a4(42); }, $expect, 'invalid default is caught when trying to push' ); like( exception { $foo->get_a4(42); }, $expect, 'invalid default is caught when trying to get' ); } { my $foo = Foo->new; is( $foo->accessor_a5(0), 'invalid', 'lazy default is coerced when trying to read via accessor' ); $foo->_clear_a5; $foo->accessor_a5( 1 => 'thing' ); is_deeply( $foo->a5, [ 'invalid', 'thing' ], 'lazy default is coerced when trying to write via accessor' ); $foo->_clear_a5; $foo->push_a5('thing'); is_deeply( $foo->a5, [ 'invalid', 'thing' ], 'lazy default is coerced when trying to push' ); $foo->_clear_a5; is( $foo->get_a5(0), 'invalid', 'lazy default is coerced when trying to get' ); } { package Bar; use Moose; } { package HasArray; use Moose; has objects => ( isa => 'ArrayRef[Foo]', traits => ['Array'], handles => { push_objects => 'push', }, ); } { my $ha = HasArray->new(); like( exception { $ha->push_objects( Bar->new ) }, qr/\QValidation failed for 'Foo'/, 'got expected error when pushing an object of the wrong class onto an array ref' ); } done_testing; more_alias_and_exclude.t100644000767000024 427312200352345 20565 0ustar00etherstaff000000000000Moose-2.1005/t/roles#!/usr/bin/perl use strict; use warnings; use Test::More; use Test::Fatal; { package Foo; use Moose::Role; sub foo { 'Foo::foo' } sub bar { 'Foo::bar' } sub baz { 'Foo::baz' } sub gorch { 'Foo::gorch' } package Bar; use Moose::Role; sub foo { 'Bar::foo' } sub bar { 'Bar::bar' } sub baz { 'Bar::baz' } sub gorch { 'Bar::gorch' } package Baz; use Moose::Role; sub foo { 'Baz::foo' } sub bar { 'Baz::bar' } sub baz { 'Baz::baz' } sub gorch { 'Baz::gorch' } package Gorch; use Moose::Role; sub foo { 'Gorch::foo' } sub bar { 'Gorch::bar' } sub baz { 'Gorch::baz' } sub gorch { 'Gorch::gorch' } } { package My::Class; use Moose; ::is( ::exception { with 'Foo' => { -excludes => [qw/bar baz gorch/], -alias => { gorch => 'foo_gorch' } }, 'Bar' => { -excludes => [qw/foo baz gorch/] }, 'Baz' => { -excludes => [qw/foo bar gorch/], -alias => { foo => 'baz_foo', bar => 'baz_bar' } }, 'Gorch' => { -excludes => [qw/foo bar baz/] }; }, undef, '... everything works out all right' ); } my $c = My::Class->new; isa_ok($c, 'My::Class'); is($c->foo, 'Foo::foo', '... got the right method'); is($c->bar, 'Bar::bar', '... got the right method'); is($c->baz, 'Baz::baz', '... got the right method'); is($c->gorch, 'Gorch::gorch', '... got the right method'); is($c->foo_gorch, 'Foo::gorch', '... got the right method'); is($c->baz_foo, 'Baz::foo', '... got the right method'); is($c->baz_bar, 'Baz::bar', '... got the right method'); { package Splunk; use Moose::Role; sub baz { 'Splunk::baz' } sub gorch { 'Splunk::gorch' } ::is(::exception { with 'Foo' }, undef, 'role to role application works'); package My::Class2; use Moose; ::is(::exception { with 'Splunk' }, undef, 'and the role can be consumed'); } is(My::Class2->foo, 'Foo::foo', '... got the right method'); is(My::Class2->bar, 'Foo::bar', '... got the right method'); is(My::Class2->baz, 'Splunk::baz', '... got the right method'); is(My::Class2->gorch, 'Splunk::gorch', '... got the right method'); done_testing; reinitialize_anon_role.t100644000767000024 144212200352345 20636 0ustar00etherstaff000000000000Moose-2.1005/t/roles#!/usr/bin/env perl use strict; use warnings; use Test::More; { package Role::Metarole; use Moose::Role; } my ($role2); { my $role1 = Moose::Meta::Role->create_anon_role( methods => { foo => sub { }, }, ); ok($role1->has_method('foo'), "role has method foo"); $role2 = Moose::Util::MetaRole::apply_metaroles( for => $role1->name, role_metaroles => { role => ['Role::Metarole'] }, ); isnt($role1, $role2, "anon role was reinitialized"); is($role1->name, $role2->name, "but it's the same anon role"); is_deeply([sort $role2->get_method_list], ['foo', 'meta'], "has the right methods"); } is_deeply([sort $role2->get_method_list], ['foo', 'meta'], "still has the right methods"); done_testing; runtime_roles_w_params.t100644000767000024 326012200352345 20672 0ustar00etherstaff000000000000Moose-2.1005/t/roles#!/usr/bin/perl use strict; use warnings; use Test::More; use Test::Fatal; { package Foo; use Moose; has 'bar' => (is => 'ro'); package Bar; use Moose::Role; has 'baz' => (is => 'ro', default => 'BAZ'); } # normal ... { my $foo = Foo->new(bar => 'BAR'); isa_ok($foo, 'Foo'); is($foo->bar, 'BAR', '... got the expect value'); ok(!$foo->can('baz'), '... no baz method though'); is( exception { Bar->meta->apply($foo) }, undef, '... this works' ); is($foo->bar, 'BAR', '... got the expect value'); ok($foo->can('baz'), '... we have baz method now'); is($foo->baz, 'BAZ', '... got the expect value'); } # with extra params ... { my $foo = Foo->new(bar => 'BAR'); isa_ok($foo, 'Foo'); is($foo->bar, 'BAR', '... got the expect value'); ok(!$foo->can('baz'), '... no baz method though'); is( exception { Bar->meta->apply($foo, (rebless_params => { baz => 'FOO-BAZ' })) }, undef, '... this works' ); is($foo->bar, 'BAR', '... got the expect value'); ok($foo->can('baz'), '... we have baz method now'); is($foo->baz, 'FOO-BAZ', '... got the expect value'); } # with extra params ... { my $foo = Foo->new(bar => 'BAR'); isa_ok($foo, 'Foo'); is($foo->bar, 'BAR', '... got the expect value'); ok(!$foo->can('baz'), '... no baz method though'); is( exception { Bar->meta->apply($foo, (rebless_params => { bar => 'FOO-BAR', baz => 'FOO-BAZ' })) }, undef, '... this works' ); is($foo->bar, 'FOO-BAR', '... got the expect value'); ok($foo->can('baz'), '... we have baz method now'); is($foo->baz, 'FOO-BAZ', '... got the expect value'); } done_testing; todo_tests000755000767000024 012200352345 14627 5ustar00etherstaff000000000000Moose-2.1005/tmoose_and_threads.t100644000767000024 140012200352345 20625 0ustar00etherstaff000000000000Moose-2.1005/t/todo_tests#!/usr/bin/perl use strict; use warnings; use Test::More; =pod See this for some details: http://bugs.debian.org/cgi-bin/bugreport.cgi?bug=476579 Here is the basic test case, it segfaults, so I am going to leave it commented out. Basically it seems that there is some bad interaction between the ??{} construct that is used in the "parser" for type definitions and threading so probably the fix would involve removing the ??{} usage for something else. use threads; { package Foo; use Moose; has "bar" => (is => 'rw', isa => "Str | Num"); } my $thr = threads->create(sub {}); $thr->join(); =cut { local $TODO = 'This is just a stub for the test, see the POD'; fail('Moose type constraints and threads dont get along'); } done_testing; throw_error.t100644000767000024 47412200352345 20736 0ustar00etherstaff000000000000Moose-2.1005/t/type_constraintsuse strict; use warnings; use Test::More; use Moose::Util::TypeConstraints; eval { Moose::Util::TypeConstraints::create_type_constraint_union() }; like( $@, qr/\QYou must pass in at least 2 type names to make a union/, 'can throw a proper error without Moose being loaded by the caller' ); done_testing; union_types.t100644000767000024 1247712200352345 21004 0ustar00etherstaff000000000000Moose-2.1005/t/type_constraints#!/usr/bin/perl use strict; use warnings; use Test::More; use Moose::Util::TypeConstraints; my $Str = find_type_constraint('Str'); isa_ok( $Str, 'Moose::Meta::TypeConstraint' ); my $Undef = find_type_constraint('Undef'); isa_ok( $Undef, 'Moose::Meta::TypeConstraint' ); ok( !$Str->check(undef), '... Str cannot accept an Undef value' ); ok( $Str->check('String'), '... Str can accept an String value' ); ok( !$Undef->check('String'), '... Undef cannot accept an Str value' ); ok( $Undef->check(undef), '... Undef can accept an Undef value' ); my $Str_or_Undef = Moose::Meta::TypeConstraint::Union->new( type_constraints => [ $Str, $Undef ] ); isa_ok( $Str_or_Undef, 'Moose::Meta::TypeConstraint::Union' ); ok( $Str_or_Undef->check(undef), '... (Str | Undef) can accept an Undef value' ); ok( $Str_or_Undef->check('String'), '... (Str | Undef) can accept a String value' ); ok( !$Str_or_Undef->is_a_type_of($Str), "not a subtype of Str" ); ok( !$Str_or_Undef->is_a_type_of($Undef), "not a subtype of Undef" ); cmp_ok( $Str_or_Undef->find_type_for('String'), 'eq', 'Str', 'find_type_for Str' ); cmp_ok( $Str_or_Undef->find_type_for(undef), 'eq', 'Undef', 'find_type_for Undef' ); ok( !defined( $Str_or_Undef->find_type_for( sub { } ) ), 'no find_type_for CodeRef' ); ok( !$Str_or_Undef->equals($Str), "not equal to Str" ); ok( $Str_or_Undef->equals($Str_or_Undef), "equal to self" ); ok( $Str_or_Undef->equals( Moose::Meta::TypeConstraint::Union->new( type_constraints => [ $Str, $Undef ] ) ), "equal to clone" ); ok( $Str_or_Undef->equals( Moose::Meta::TypeConstraint::Union->new( type_constraints => [ $Undef, $Str ] ) ), "equal to reversed clone" ); ok( !$Str_or_Undef->is_a_type_of("ThisTypeDoesNotExist"), "not type of non existent type" ); ok( !$Str_or_Undef->is_subtype_of("ThisTypeDoesNotExist"), "not subtype of non existent type" ); is( $Str_or_Undef->parent, find_type_constraint('Item'), 'parent of Str|Undef is Item' ); is_deeply( [$Str_or_Undef->parents], [find_type_constraint('Item')], 'parents of Str|Undef is Item' ); # another .... my $ArrayRef = find_type_constraint('ArrayRef'); isa_ok( $ArrayRef, 'Moose::Meta::TypeConstraint' ); my $HashRef = find_type_constraint('HashRef'); isa_ok( $HashRef, 'Moose::Meta::TypeConstraint' ); ok( $ArrayRef->check( [] ), '... ArrayRef can accept an [] value' ); ok( !$ArrayRef->check( {} ), '... ArrayRef cannot accept an {} value' ); ok( $HashRef->check( {} ), '... HashRef can accept an {} value' ); ok( !$HashRef->check( [] ), '... HashRef cannot accept an [] value' ); my $ArrayRef_or_HashRef = Moose::Meta::TypeConstraint::Union->new( type_constraints => [ $ArrayRef, $HashRef ] ); isa_ok( $ArrayRef_or_HashRef, 'Moose::Meta::TypeConstraint::Union' ); ok( $ArrayRef_or_HashRef->check( [] ), '... (ArrayRef | HashRef) can accept []' ); ok( $ArrayRef_or_HashRef->check( {} ), '... (ArrayRef | HashRef) can accept {}' ); ok( !$ArrayRef_or_HashRef->check( \( my $var1 ) ), '... (ArrayRef | HashRef) cannot accept scalar refs' ); ok( !$ArrayRef_or_HashRef->check( sub { } ), '... (ArrayRef | HashRef) cannot accept code refs' ); ok( !$ArrayRef_or_HashRef->check(50), '... (ArrayRef | HashRef) cannot accept Numbers' ); diag $ArrayRef_or_HashRef->validate( [] ); ok( !defined( $ArrayRef_or_HashRef->validate( [] ) ), '... (ArrayRef | HashRef) can accept []' ); ok( !defined( $ArrayRef_or_HashRef->validate( {} ) ), '... (ArrayRef | HashRef) can accept {}' ); like( $ArrayRef_or_HashRef->validate( \( my $var2 ) ), qr/Validation failed for \'ArrayRef\' with value .+ and Validation failed for \'HashRef\' with value .+ in \(ArrayRef\|HashRef\)/, '... (ArrayRef | HashRef) cannot accept scalar refs' ); like( $ArrayRef_or_HashRef->validate( sub { } ), qr/Validation failed for \'ArrayRef\' with value .+ and Validation failed for \'HashRef\' with value .+ in \(ArrayRef\|HashRef\)/, '... (ArrayRef | HashRef) cannot accept code refs' ); is( $ArrayRef_or_HashRef->validate(50), 'Validation failed for \'ArrayRef\' with value 50 and Validation failed for \'HashRef\' with value 50 in (ArrayRef|HashRef)', '... (ArrayRef | HashRef) cannot accept Numbers' ); is( $ArrayRef_or_HashRef->parent, find_type_constraint('Ref'), 'parent of ArrayRef|HashRef is Ref' ); my $double_union = Moose::Meta::TypeConstraint::Union->new( type_constraints => [ $Str_or_Undef, $ArrayRef_or_HashRef ] ); is( $double_union->parent, find_type_constraint('Item'), 'parent of (Str|Undef)|(ArrayRef|HashRef) is Item' ); ok( $double_union->is_subtype_of('Item'), '(Str|Undef)|(ArrayRef|HashRef) is a subtype of Item' ); ok( $double_union->is_a_type_of('Item'), '(Str|Undef)|(ArrayRef|HashRef) is a type of Item' ); ok( !$double_union->is_a_type_of('Str'), '(Str|Undef)|(ArrayRef|HashRef) is not a type of Str' ); type 'SomeType', where { 1 }; type 'OtherType', where { 1 }; my $parentless_union = Moose::Meta::TypeConstraint::Union->new( type_constraints => [ find_type_constraint('SomeType'), find_type_constraint('OtherType'), ], ); is($parentless_union->parent, undef, "no common ancestor gives undef parent"); done_testing; changes_has_content.t100644000767000024 201212200352345 20565 0ustar00etherstaff000000000000Moose-2.1005/xt/release#!perl use Test::More tests => 2; note 'Checking Changes'; my $changes_file = 'Changes'; my $newver = '2.1005'; my $trial_token = '-TRIAL'; SKIP: { ok(-e $changes_file, "$changes_file file exists") or skip 'Changes is missing', 1; ok(_get_changes($newver), "$changes_file has content for $newver"); } done_testing; # _get_changes copied and adapted from Dist::Zilla::Plugin::Git::Commit # by Jerome Quelin sub _get_changes { my $newver = shift; # parse changelog to find commit message open(my $fh, '<', $changes_file) or die "cannot open $changes_file: $!"; my $changelog = join('', <$fh>); close $fh; my @content = grep { /^$newver(?:$trial_token)?(?:\s+|$)/ ... /^\S/ } # from newver to un-indented split /\n/, $changelog; shift @content; # drop the version line # drop unindented last line and trailing blank lines pop @content while ( @content && $content[-1] =~ /^(?:\S|\s*$)/ ); # return number of non-blank lines return scalar @content; } Generated.pm100644000767000024 455012200352345 20263 0ustar00etherstaff000000000000Moose-2.1005/lib/Class/MOP/Method package Class::MOP::Method::Generated; BEGIN { $Class::MOP::Method::Generated::AUTHORITY = 'cpan:STEVAN'; } { $Class::MOP::Method::Generated::VERSION = '2.1005'; } use strict; use warnings; use Carp 'confess'; use Eval::Closure; use base 'Class::MOP::Method'; ## accessors sub new { confess __PACKAGE__ . " is an abstract base class, you must provide a constructor."; } sub _initialize_body { confess "No body to initialize, " . __PACKAGE__ . " is an abstract base class"; } sub _generate_description { my ( $self, $context ) = @_; $context ||= $self->definition_context; my $desc = "generated method"; my $origin = "unknown origin"; if (defined $context) { if (defined $context->{description}) { $desc = $context->{description}; } if (defined $context->{file} || defined $context->{line}) { $origin = "defined at " . (defined $context->{file} ? $context->{file} : "") . " line " . (defined $context->{line} ? $context->{line} : ""); } } return "$desc ($origin)"; } sub _compile_code { my ( $self, @args ) = @_; unshift @args, 'source' if @args % 2; my %args = @args; my $context = delete $args{context}; my $environment = $self->can('_eval_environment') ? $self->_eval_environment : {}; return eval_closure( environment => $environment, description => $self->_generate_description($context), %args, ); } 1; # ABSTRACT: Abstract base class for generated methods __END__ =pod =head1 NAME Class::MOP::Method::Generated - Abstract base class for generated methods =head1 VERSION version 2.1005 =head1 DESCRIPTION This is a C subclass which is subclassed by C and C. It is not intended to be used directly. =head1 AUTHOR Moose is maintained by the Moose Cabal, along with the help of many contributors. See L and L for details. =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2013 by Infinity Interactive, Inc.. This is free software; you can redistribute it and/or modify it under the same terms as the Perl 5 programming language system itself. =cut Mixin000755000767000024 012200352345 15527 5ustar00etherstaff000000000000Moose-2.1005/lib/Class/MOPHasMethods.pm100644000767000024 2071412200352345 20310 0ustar00etherstaff000000000000Moose-2.1005/lib/Class/MOP/Mixinpackage Class::MOP::Mixin::HasMethods; BEGIN { $Class::MOP::Mixin::HasMethods::AUTHORITY = 'cpan:STEVAN'; } { $Class::MOP::Mixin::HasMethods::VERSION = '2.1005'; } use strict; use warnings; use Class::MOP::Method::Meta; use Class::MOP::Method::Overload; use Scalar::Util 'blessed', 'reftype'; use Carp 'confess'; use Sub::Name 'subname'; use overload (); use base 'Class::MOP::Mixin'; sub _meta_method_class { 'Class::MOP::Method::Meta' } sub _add_meta_method { my $self = shift; my ($name) = @_; my $existing_method = $self->can('find_method_by_name') ? $self->find_method_by_name($name) : $self->get_method($name); return if $existing_method && $existing_method->isa($self->_meta_method_class); $self->add_method( $name => $self->_meta_method_class->wrap( name => $name, package_name => $self->name, associated_metaclass => $self, ) ); } sub wrap_method_body { my ( $self, %args ) = @_; ( 'CODE' eq reftype $args{body} ) || confess "Your code block must be a CODE reference"; $self->method_metaclass->wrap( package_name => $self->name, %args, ); } sub add_method { my ( $self, $method_name, $method ) = @_; ( defined $method_name && length $method_name ) || confess "You must define a method name"; my $package_name = $self->name; my $body; if ( blessed($method) && $method->isa('Class::MOP::Method') ) { $body = $method->body; if ( $method->package_name ne $package_name ) { $method = $method->clone( package_name => $package_name, name => $method_name, ); } $method->attach_to_class($self); } else { # If a raw code reference is supplied, its method object is not created. # The method object won't be created until required. $body = $method; } $self->_method_map->{$method_name} = $method; my ($current_package, $current_name) = Class::MOP::get_code_info($body); subname($package_name . '::' . $method_name, $body) unless defined $current_name && $current_name !~ /^__ANON__/; $self->add_package_symbol("&$method_name", $body); # we added the method to the method map too, so it's still valid $self->update_package_cache_flag; } sub _code_is_mine { my ( $self, $code ) = @_; my ( $code_package, $code_name ) = Class::MOP::get_code_info($code); return ( $code_package && $code_package eq $self->name ) || ( $code_package eq 'constant' && $code_name eq '__ANON__' ); } sub has_method { my ( $self, $method_name ) = @_; ( defined $method_name && length $method_name ) || confess "You must define a method name"; my $method = $self->_get_maybe_raw_method($method_name) or return; return defined($self->_method_map->{$method_name} = $method); } sub get_method { my ( $self, $method_name ) = @_; ( defined $method_name && length $method_name ) || confess "You must define a method name"; my $method = $self->_get_maybe_raw_method($method_name) or return; return $method if blessed($method) && $method->isa('Class::MOP::Method'); return $self->_method_map->{$method_name} = $self->wrap_method_body( body => $method, name => $method_name, associated_metaclass => $self, ); } sub _get_maybe_raw_method { my ( $self, $method_name ) = @_; my $map_entry = $self->_method_map->{$method_name}; return $map_entry if defined $map_entry; my $code = $self->get_package_symbol("&$method_name"); return unless $code && $self->_code_is_mine($code); return $code; } sub remove_method { my ( $self, $method_name ) = @_; ( defined $method_name && length $method_name ) || confess "You must define a method name"; my $removed_method = delete $self->_method_map->{$method_name}; $self->remove_package_symbol("&$method_name"); $removed_method->detach_from_class if blessed($removed_method) && $removed_method->isa('Class::MOP::Method'); # still valid, since we just removed the method from the map $self->update_package_cache_flag; return $removed_method; } sub get_method_list { my $self = shift; return keys %{ $self->_full_method_map }; } sub _get_local_methods { my $self = shift; return values %{ $self->_full_method_map }; } sub _restore_metamethods_from { my $self = shift; my ($old_meta) = @_; for my $method ($old_meta->_get_local_methods) { $method->_make_compatible_with($self->method_metaclass); $self->add_method($method->name => $method); } } sub reset_package_cache_flag { (shift)->{'_package_cache_flag'} = undef } sub update_package_cache_flag { my $self = shift; # NOTE: # we can manually update the cache number # since we are actually adding the method # to our cache as well. This avoids us # having to regenerate the method_map. # - SL $self->{'_package_cache_flag'} = Class::MOP::check_package_cache_flag($self->name); } sub _full_method_map { my $self = shift; my $pkg_gen = Class::MOP::check_package_cache_flag($self->name); if (($self->{_package_cache_flag_full} || -1) != $pkg_gen) { # forcibly reify all method map entries $self->get_method($_) for $self->list_all_package_symbols('CODE'); $self->{_package_cache_flag_full} = $pkg_gen; } return $self->_method_map; } # overloading my $overload_operators; sub overload_operators { $overload_operators ||= [map { split /\s+/ } values %overload::ops]; return @$overload_operators; } sub is_overloaded { my $self = shift; return overload::Overloaded($self->name); } # XXX this could probably stand to be cached, but i figure it should be # uncommon enough to not particularly matter sub _overload_map { my $self = shift; return {} unless $self->is_overloaded; my %map; for my $op ($self->overload_operators) { my $body = $self->_get_overloaded_operator_body($op); next unless defined $body; $map{$op} = $body; } return \%map; } sub get_overload_list { my $self = shift; return keys %{ $self->_overload_map }; } sub get_all_overloaded_operators { my $self = shift; my $map = $self->_overload_map; return map { $self->_wrap_overload($_, $map->{$_}) } keys %$map; } sub has_overloaded_operator { my $self = shift; my ($op) = @_; return defined $self->_get_overloaded_operator_body($op); } sub get_overloaded_operator { my $self = shift; my ($op) = @_; my $body = $self->_get_overloaded_operator_body($op); return unless defined $body; return $self->_wrap_overload($op, $body); } sub add_overloaded_operator { my $self = shift; my ($op, $body) = @_; $self->name->overload::OVERLOAD($op => $body); } sub remove_overloaded_operator { my $self = shift; my ($op) = @_; if ( $] < 5.018 ) { # ugh, overload.pm provides no api for this - but the problem that # makes this necessary has been fixed in 5.18 $self->get_or_add_package_symbol('%OVERLOAD')->{dummy}++; } $self->remove_package_symbol('&(' . $op); } sub _get_overloaded_operator_body { my $self = shift; my ($op) = @_; return overload::Method($self->name, $op); } sub _wrap_overload { my $self = shift; my ($op, $body) = @_; return Class::MOP::Method::Overload->wrap( operator => $op, package_name => $self->name, associated_metaclass => $self, body => $body, ); } 1; # ABSTRACT: Methods for metaclasses which have methods __END__ =pod =head1 NAME Class::MOP::Mixin::HasMethods - Methods for metaclasses which have methods =head1 VERSION version 2.1005 =head1 DESCRIPTION This class implements methods for metaclasses which have methods (L and L). See L for API details. =head1 AUTHOR Moose is maintained by the Moose Cabal, along with the help of many contributors. See L and L for details. =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2013 by Infinity Interactive, Inc.. This is free software; you can redistribute it and/or modify it under the same terms as the Perl 5 programming language system itself. =cut Construction.pod100644000767000024 1377312200352345 20633 0ustar00etherstaff000000000000Moose-2.1005/lib/Moose/Manualpackage Moose::Manual::Construction; # ABSTRACT: Object construction (and destruction) with Moose __END__ =pod =head1 NAME Moose::Manual::Construction - Object construction (and destruction) with Moose =head1 VERSION version 2.1005 =head1 WHERE'S THE CONSTRUCTOR? B method for your classes!> When you C in your class, your class becomes a subclass of L. The L provides a C method for your class. If you follow our recommendations in L and make your class immutable, then you actually get a class-specific C method "inlined" in your class. =head1 OBJECT CONSTRUCTION AND ATTRIBUTES The Moose-provided constructor accepts a hash or hash reference of named parameters matching your attributes (actually, matching their Cs). This is just another way in which Moose keeps you from worrying I classes are implemented. Simply define a class and you're ready to start creating objects! =head1 OBJECT CONSTRUCTION HOOKS Moose lets you hook into object construction. You can validate an object's state, do logging, customize construction from parameters which do not match your attributes, or maybe allow non-hash(ref) constructor arguments. You can do this by creating C and/or C methods. If these methods exist in your class, Moose will arrange for them to be called as part of the object construction process. =head2 BUILDARGS The C method is called as a class method I an object is created. It will receive all of the arguments that were passed to C I, and is expected to return a hash reference. This hash reference will be used to construct the object, so it should contain keys matching your attributes' names (well, Cs). One common use for C is to accommodate a non-hash(ref) calling style. For example, we might want to allow our Person class to be called with a single argument of a social security number, C<< Person->new($ssn) >>. Without a C method, Moose will complain, because it expects a hash or hash reference. We can use the C method to accommodate this calling style: around BUILDARGS => sub { my $orig = shift; my $class = shift; if ( @_ == 1 && !ref $_[0] ) { return $class->$orig( ssn => $_[0] ); } else { return $class->$orig(@_); } }; Note the call to C<< $class->$orig >>. This will call the default C in L. This method takes care of distinguishing between a hash reference and a plain hash for you. =head2 BUILD The C method is called I an object is created. There are several reasons to use a C method. One of the most common is to check that the object state is valid. While we can validate individual attributes through the use of types, we can't validate the state of a whole object that way. sub BUILD { my $self = shift; if ( $self->country_of_residence eq 'USA' ) { die 'All US residents must have an SSN' unless $self->has_ssn; } } Another use of a C method could be for logging or tracking object creation. sub BUILD { my $self = shift; debug( 'Made a new person - SSN = ', $self->ssn, ); } The C method is called with the hash reference of the parameters passed to the constructor (after munging by C). This gives you a chance to do something with parameters that do not represent object attributes. sub BUILD { my $self = shift; my $args = shift; $self->add_friend( My::User->new( user_id => $args->{user_id}, ) ); } =head3 BUILD and parent classes The interaction between multiple C methods in an inheritance hierarchy is different from normal Perl methods. BSUPER::BUILD >>>, nor should you ever apply a method modifier to C. Moose arranges to have all of the C methods in a hierarchy called when an object is constructed, I. This might be surprising at first, because it reverses the normal order of method inheritance. The theory behind this is that C methods can only be used for increasing specialization of a class's constraints, so it makes sense to call the least specific C method first. Also, this is how Perl 6 does it. =head1 OBJECT DESTRUCTION Moose provides a hook for object destruction with the C method. As with C, you should never explicitly call C<< $self->SUPER::DEMOLISH >>. Moose will arrange for all of the C methods in your hierarchy to be called, from most to least specific. Each C method is called with a single argument. In most cases, Perl's built-in garbage collection is sufficient, and you won't need to provide a C method. =head2 Error Handling During Destruction The interaction of object destruction and Perl's global C<$@> and C<$?> variables can be very confusing. Moose always localizes C<$?> when an object is being destroyed. This means that if you explicitly call C, that exit code will be preserved even if an object's destructor makes a system call. Moose also preserves C<$@> against any C calls that may happen during object destruction. However, if an object's C method actually dies, Moose explicitly rethrows that error. If you do not like this behavior, you will have to provide your own C method and use that instead of the one provided by L. You can do this to preserve C<$@> I capture any errors from object destruction by creating an error stack. =head1 AUTHOR Moose is maintained by the Moose Cabal, along with the help of many contributors. See L and L for details. =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2013 by Infinity Interactive, Inc.. This is free software; you can redistribute it and/or modify it under the same terms as the Perl 5 programming language system itself. =cut Contributing.pod100644000767000024 4556412200352345 20613 0ustar00etherstaff000000000000Moose-2.1005/lib/Moose/Manualpackage Moose::Manual::Contributing; # ABSTRACT: How to get involved in Moose __END__ =pod =head1 NAME Moose::Manual::Contributing - How to get involved in Moose =head1 VERSION version 2.1005 =head1 GETTING INVOLVED Moose is an open project, and we are always willing to accept bug fixes, more tests, and documentation patches. Commit bits are given out freely and it's easy to get started! =head2 Get the Code If you just want to get your feet wet and check out the code, you can do so from the comfort of your web browser by going to the official repository on GitHub: L. However, if you know how to use git and would rather have a local copy (because, why wouldn't you?!), then you can clone it: git clone git@github.com:moose/moose.git If, at some point, you think you'd like to contribute a patch, please see L. I Your contribution is very important to us. If, for some reason, you would prefer not to use Git/GitHub, come talk to us at #moose on irc.perl.org and we can work something out.> =head2 People As Moose has matured, some structure has emerged in the process. =over =item Cabal - people who can release moose These people are the ones who have co-maint on Moose itself and can create a release. They're listed under L in the Moose documentation. They are responsible for reviewing branches, and are the only people who are allowed to push to stable branches. Cabal members are listed in L and can often be found on irc in the L channel. =item Contributors - people creating a topic or branch You! =back =head2 New Features Moose already has a fairly large feature set, and we are currently B looking to add any major new features to it. If you have an idea for a new feature in Moose, you are encouraged to create a MooseX module first. At this stage, no new features will even be considered for addition into the core without first being vetted as a MooseX module, unless it is absolutely 100% impossible to implement the feature outside the core. If you think it is 100% impossible, please come discuss it with us on IRC or via e-mail. Your feature may need a small hook in the core, or a refactoring of some core modules, and we are definitely open to that. Moose was built from the ground up with the idea of being highly extensible, and quite often the feature requests we see can be implemented through small extensions. Try it, it's much easier than you might think. =head2 Branch Layout The repository is divided into several branches to make maintenance easier for everyone involved. The branches below are ordered by level of stability. =over =item stable/* The branch from which releases are cut. When making a new major release, the release manager makes a new C branch at the current position of C. The version used in the stable branch should not include the last two digits of the version number. For minor releases, patches will be committed to C, and backported (cherry-picked) to the appropriate stable branch as needed. A stable branch is only updated by someone from the Cabal during a release. =item master The main development branch. All new code should be written against this branch. This branch contains code that has been reviewed, and will be included in the next major release. Commits which are judged to not break backwards compatibility may be backported into C to be included in the next minor release. =item topic/* Small personal branches that are still in progress. They can be freely rebased. They contain targeted features that may span a handful of commits. Any change or bugfix should be created in a topic branch. =item rfc/* Topic branches that are completed and waiting on review. A Cabal member will look over branches in this namespace, and either merge them to C if they are acceptable, or move them back to a different namespace otherwise. This namespace is being phased out now that we are using GitHub's pull requests in our L. =item attic/* Branches which have been reviewed, and rejected. They remain in the repository in case we later change our mind, or in case parts of them are still useful. =item abandoned/* Topic branches which have had no activity for a long period of time will be moved here, to keep the main areas clean. =back Larger, longer term branches can also be created in the root namespace (i.e. at the same level as master and stable). This may be appropriate if multiple people are intending to work on the branch. These branches should not be rebased without checking with other developers first. =head1 WORKFLOWS =head2 Getting Started So, you've cloned the main Moose repository to your local machine (see L) and you're ready to do some hacking. We couldn't be happier to welcome you to our community! Of course, to ensure that your first experience is as productive and satisfying as possible, you should probably take some time to read over this entire POD document. Doing so will give you a full understanding of how Moose developers and maintainers work together and what they expect from one another. Done? Great! Next, assuming you have a GitHub account, go to L and B (see L). This will put an exact replica of the Moose repository into your GitHub account, which will serve as a place to publish your patches for the Moose maintainers to review and incorporate. Once your fork has been created, switch to your local working repository directory and update your C remote's push URL. This allows you to use a single remote (C) to both pull in the latest code from GitHub and also push your work to your own fork: # Replace YOUR_USERNAME below with your GitHub username git remote set-url --push origin git@github.com:YOUR_USERNAME/moose.git You can verify your work: $ git remote -v origin git@github.com:moose/moose.git (fetch) origin git@github.com:YOUR_USERNAME/moose.git (push) Now, you're ready for action! From now on, you just follow the L to publish your work and B to the Moose Cabal. =head2 Development Workflow The general gist of the B is: =over 4 =item 1. Update your local repository with the latest commits from the official repository =item 2. Create a new topic branch, based on the master branch =item 3. Hack away =item 4. Commit and push the topic branch to your forked repository =item 5. Submit a pull request through GitHub for that branch =back What follows is a more detailed rundown of that workflow. Please make sure to review and follow the steps in the previous section, L, if you have not done so already. =head3 Update Your Repository Update your local copy of the master branch from the remote: git checkout master git pull --rebase =head3 Create Your Topic Branch Now, create a new topic branch based on your master branch. It's useful to use concise, descriptive branch names such as: pod-syntax-contrib, feat-autodelegation, patch-23-role-comp, etc. However, we'll just call ours C for demonstration purposes: git checkout -b topic/my-feature =head3 Hack. Commit. Repeat. While you're hacking, the most important thing to remember is that your topic branch is yours to do with as you like. Nothing you do there will affect anyone else at this point. Commit as often as little or as often as you need to and don't let perfection get in the way of progress. However, don't try to do too much as the easiest changes to integrate are small and focused. If it's been a while since you created your topic branch, it's often a good idea to periodically rebase your branch off of the upstream master to reduce your work later on: git fetch # or, git remote update git rebase origin/master # or, git pull --rebase origin master You should also feel free to publish (using C if necessary) your branch to your GitHub fork if you simply need feedback from others. (Note: actual collaboration takes a bit more finesse and a lot less C<--force> however). =head3 Clean Up Your Branch Finally, when your development is done, it's time to prepare your branch for review. Even the smallest branches can often use a little bit of tidying up before they are unleashed on a reviewer. Clarifying/cleaning up commit messages, reordering commits, splitting large commits or those which contain different types of changes, squashing related or straggler commits are all B worthwhile activities to undertake on your topic branch. B Your topic branch is yours. Don't worry about rewriting its history or breaking fast-forward. Some useful commands are listed below but please make sure that you understand what they do as they can rewrite history: - git commit --amend - git rebase --interactive - git cherry-pick Ultimately, your goal in cleaning up your branch is to craft a set of commits whose content and messages are as focused and understandable as possible. Doing so will greatly increase the chances of a speedy review and acceptance into the mainline development. =head3 Rebase on the Latest Before your final push and issuing a pull request, you need to ensure that your changes can be easily merged into the master branch of the upstream repository. This is done by once again rebasing your branch on the latest C. git fetch # or, git remote update git rebase origin/master # or, git pull --rebase origin master =head3 Publish and Pull Request Now it's time to make your final push of the branch to your fork. The C<--force> flag is only necessary if you've pushed before and subsequently rewriting your history: git push --force After your branch is published, you can issue a pull request to the Moose Cabal. See for details. Congratulations! You're now a contributor! =head2 Approval Workflow Moose is an open project but it is also an increasingly important one. Many modules depend on Moose being stable. Therefore, we have a basic set of criteria for reviewing and merging branches. What follows is a set of rough guidelines that ensures all new code is properly vetted before it is merged to the master branch. It should be noted that if you want your specific branch to be approved, it is B responsibility to follow this process and advocate for your branch. =over 4 =item Small bug fixes, doc patches and additional passing tests. These items don't really require approval beyond one of the core contributors just doing a simple review. For especially simple patches (doc patches especially), committing directly to master is fine. =item Larger bug fixes, doc additions and TODO or failing tests. Larger bug fixes should be reviewed by at least one cabal member and should be tested using the F test. New documentation is always welcome, but should also be reviewed by a cabal member for accuracy. TODO tests are basically feature requests, see our L section for more information on that. If your feature needs core support, create a C branch using the L and start hacking away. Failing tests are basically bug reports. You should find a core contributor and/or cabal member to see if it is a real bug, then submit the bug and your test to the RT queue. Source control is not a bug reporting tool. =item New user-facing features. Anything that creates a new user-visible feature needs to be approved by B cabal member. Make sure you have reviewed L to be sure that you are following the guidelines. Do not be surprised if a new feature is rejected for the core. =item New internals features. New features for Moose internals are less restrictive than user facing features, but still require approval by B cabal member. Ideally you will have run the F script to be sure you are not breaking any MooseX module or causing any other unforeseen havoc. If you do this (rather than make us do it), it will only help to hasten your branch's approval. =item Backwards incompatible changes. Anything that breaks backwards compatibility must be discussed by the cabal. Backwards incompatible changes should not be merged to master if there are strong objections from any cabal members. We have a policy for what we see as sane L for Moose. If your changes break back-compat, you must be ready to discuss and defend your change. =back =head2 Release Workflow # major releases (including trial releases) git checkout master # minor releases git checkout stable/X.YY # do final changelogging, etc vim dist.ini # increment version number git commit dzil release # or dzil release --trial for trial releases git commit # to add the actual release date git branch stable/X.YY # only for non-trial major releases =head3 Release How-To Moose uses L to manage releases. Although the git repository comes with a C, it is a very basic one just to allow the basic C cycle to work. In particular, it doesn't include any release metadata, such as dependencies. In order to get started with Dist::Zilla, first install it: C, and then install the plugins necessary for reading the C: C. Moose releases fall into two categories, each with their own level of release preparation. A minor release is one which does not include any API changes, deprecations, and so on. In that case, it is sufficient to simply test the release candidate against a few different Perls. Testing should be done against at least two recent major versions of Perl (5.8.8 and 5.10.1, for example). If you have more versions available, you are encouraged to test them all. However, we do not put a lot of effort into supporting older 5.8.x releases. For major releases which include an API change or deprecation, you should run the F test. This tests a long list of MooseX and other Moose-using modules from CPAN. In order to run this script, you must arrange to have the new version of Moose in Perl's include path. You can use C and C, install the module, or fiddle with the C environment variable, whatever makes you happy. This test downloads each module from CPAN, runs its tests, and logs failures and warnings to a set of files named F. If there are failures or warnings, please work with the authors of the modules in question to fix them. If the module author simply isn't available or does not want to fix the bug, it is okay to make a release. Regardless of whether or not a new module is available, any breakages should be noted in the conflicts list in the distribution's F. =head2 Emergency Bug Workflow (for immediate release) The stable branch exists for easily making bug fix releases. git remote update git checkout -b topic/my-emergency-fix origin/master # hack git commit Then a cabal member merges into C, and backports the change into C: git checkout master git merge topic/my-emergency-fix git push git checkout stable/X.YY git cherry-pick -x master git push # release =head2 Project Workflow For longer lasting branches, we use a subversion style branch layout, where master is routinely merged into the branch. Rebasing is allowed as long as all the branch contributors are using C properly. C, C, etc. are not allowed, and should only be done in topic branches. Committing to master is still done with the same review process as a topic branch, and the branch must merge as a fast forward. This is pretty much the way we're doing branches for large-ish things right now. Obviously there is no technical limitation on the number of branches. You can freely create topic branches off of project branches, or sub projects inside larger projects freely. Such branches should incorporate the name of the branch they were made off so that people don't accidentally assume they should be merged into master: git checkout -b my-project--topic/foo my-project (unfortunately Git will not allow C as a branch name if C is a valid ref). =head1 BRANCH ARCHIVAL Merged branches should be deleted. Failed branches may be kept, but should be moved to C to differentiate them from in-progress topic branches. Branches that have not been worked on for a long time will be moved to C periodically, but feel free to move the branch back to C if you want to start working on it again. =head1 TESTS, TESTS, TESTS If you write I code for Moose, you B add tests for that code. If you do not write tests then we cannot guarantee your change will not be removed or altered at a later date, as there is nothing to confirm this is desired behavior. If your code change/addition is deep within the bowels of Moose and your test exercises this feature in a non-obvious way, please add some comments either near the code in question or in the test so that others know. We also greatly appreciate documentation to go with your changes, and an entry in the Changes file. Make sure to give yourself credit! Major changes or new user-facing features should also be documented in L. =head1 DOCS, DOCS, DOCS Any user-facing changes must be accompanied by documentation. If you're not comfortable writing docs yourself, you might be able to convince another Moose dev to help you. Our goal is to make sure that all features are documented. Undocumented features are not considered part of the API when it comes to determining whether a change is backwards compatible. =head1 BACKWARDS COMPATIBILITY Change is inevitable, and Moose is not immune to this. We do our best to maintain backwards compatibility, but we do not want the code base to become overburdened by this. This is not to say that we will be frivolous with our changes, quite the opposite, just that we are not afraid of change and will do our best to keep it as painless as possible for the end user. Our policy for handling backwards compatibility is documented in more detail in L. All backwards incompatible changes B be documented in L. Make sure to document any useful tips or workarounds for the change in that document. =head1 AUTHOR Moose is maintained by the Moose Cabal, along with the help of many contributors. See L and L for details. =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2013 by Infinity Interactive, Inc.. This is free software; you can redistribute it and/or modify it under the same terms as the Perl 5 programming language system itself. =cut Accessor.pm100644000767000024 1000512200352345 20407 0ustar00etherstaff000000000000Moose-2.1005/lib/Moose/Meta/Method package Moose::Meta::Method::Accessor; BEGIN { $Moose::Meta::Method::Accessor::AUTHORITY = 'cpan:STEVAN'; } { $Moose::Meta::Method::Accessor::VERSION = '2.1005'; } use strict; use warnings; use Try::Tiny; use base 'Moose::Meta::Method', 'Class::MOP::Method::Accessor'; # multiple inheritance is terrible sub new { goto &Class::MOP::Method::Accessor::new; } sub _new { goto &Class::MOP::Method::Accessor::_new; } sub _error_thrower { my $self = shift; return $self->associated_attribute if ref($self) && defined($self->associated_attribute); return $self->SUPER::_error_thrower; } sub _compile_code { my $self = shift; my @args = @_; try { $self->SUPER::_compile_code(@args); } catch { $self->throw_error( 'Could not create writer for ' . "'" . $self->associated_attribute->name . "' " . 'because ' . $_, error => $_, ); }; } sub _eval_environment { my $self = shift; return $self->associated_attribute->_eval_environment; } sub _instance_is_inlinable { my $self = shift; return $self->associated_attribute->associated_class->instance_metaclass->is_inlinable; } sub _generate_reader_method { my $self = shift; $self->_instance_is_inlinable ? $self->_generate_reader_method_inline(@_) : $self->SUPER::_generate_reader_method(@_); } sub _generate_writer_method { my $self = shift; $self->_instance_is_inlinable ? $self->_generate_writer_method_inline(@_) : $self->SUPER::_generate_writer_method(@_); } sub _generate_accessor_method { my $self = shift; $self->_instance_is_inlinable ? $self->_generate_accessor_method_inline(@_) : $self->SUPER::_generate_accessor_method(@_); } sub _generate_predicate_method { my $self = shift; $self->_instance_is_inlinable ? $self->_generate_predicate_method_inline(@_) : $self->SUPER::_generate_predicate_method(@_); } sub _generate_clearer_method { my $self = shift; $self->_instance_is_inlinable ? $self->_generate_clearer_method_inline(@_) : $self->SUPER::_generate_clearer_method(@_); } sub _writer_value_needs_copy { shift->associated_attribute->_writer_value_needs_copy(@_); } sub _inline_tc_code { shift->associated_attribute->_inline_tc_code(@_); } sub _inline_check_coercion { shift->associated_attribute->_inline_check_coercion(@_); } sub _inline_check_constraint { shift->associated_attribute->_inline_check_constraint(@_); } sub _inline_check_lazy { shift->associated_attribute->_inline_check_lazy(@_); } sub _inline_store_value { shift->associated_attribute->_inline_instance_set(@_) . ';'; } sub _inline_get_old_value_for_trigger { shift->associated_attribute->_inline_get_old_value_for_trigger(@_); } sub _inline_trigger { shift->associated_attribute->_inline_trigger(@_); } sub _get_value { shift->associated_attribute->_inline_instance_get(@_); } sub _has_value { shift->associated_attribute->_inline_instance_has(@_); } 1; # ABSTRACT: A Moose Method metaclass for accessors __END__ =pod =head1 NAME Moose::Meta::Method::Accessor - A Moose Method metaclass for accessors =head1 VERSION version 2.1005 =head1 DESCRIPTION This class is a subclass of L that provides additional Moose-specific functionality, all of which is private. To understand this class, you should read the the L documentation. =head1 BUGS See L for details on reporting bugs. =head1 AUTHOR Moose is maintained by the Moose Cabal, along with the help of many contributors. See L and L for details. =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2013 by Infinity Interactive, Inc.. This is free software; you can redistribute it and/or modify it under the same terms as the Perl 5 programming language system itself. =cut TypeConstraints.pm100644000767000024 12540012200352345 20653 0ustar00etherstaff000000000000Moose-2.1005/lib/Moose/Util package Moose::Util::TypeConstraints; BEGIN { $Moose::Util::TypeConstraints::AUTHORITY = 'cpan:STEVAN'; } { $Moose::Util::TypeConstraints::VERSION = '2.1005'; } use Carp (); use List::MoreUtils qw( all any ); use Scalar::Util qw( blessed reftype ); use Moose::Exporter; ## -------------------------------------------------------- # Prototyped subs must be predeclared because we have a # circular dependency with Moose::Meta::Attribute et. al. # so in case of us being use'd first the predeclaration # ensures the prototypes are in scope when consumers are # compiled. # dah sugah! sub where (&); sub via (&); sub message (&); sub optimize_as (&); sub inline_as (&); ## -------------------------------------------------------- use Moose::Deprecated; use Moose::Meta::TypeConstraint; use Moose::Meta::TypeConstraint::Union; use Moose::Meta::TypeConstraint::Parameterized; use Moose::Meta::TypeConstraint::Parameterizable; use Moose::Meta::TypeConstraint::Class; use Moose::Meta::TypeConstraint::Role; use Moose::Meta::TypeConstraint::Enum; use Moose::Meta::TypeConstraint::DuckType; use Moose::Meta::TypeCoercion; use Moose::Meta::TypeCoercion::Union; use Moose::Meta::TypeConstraint::Registry; Moose::Exporter->setup_import_methods( as_is => [ qw( type subtype class_type role_type maybe_type duck_type as where message optimize_as inline_as coerce from via enum union find_type_constraint register_type_constraint match_on_type ) ], ); ## -------------------------------------------------------- ## type registry and some useful functions for it ## -------------------------------------------------------- my $REGISTRY = Moose::Meta::TypeConstraint::Registry->new; sub get_type_constraint_registry {$REGISTRY} sub list_all_type_constraints { keys %{ $REGISTRY->type_constraints } } sub export_type_constraints_as_functions { my $pkg = caller(); no strict 'refs'; foreach my $constraint ( keys %{ $REGISTRY->type_constraints } ) { my $tc = $REGISTRY->get_type_constraint($constraint) ->_compiled_type_constraint; *{"${pkg}::${constraint}"} = sub { $tc->( $_[0] ) ? 1 : undef }; # the undef is for compat } } sub create_type_constraint_union { _create_type_constraint_union(\@_); } sub create_named_type_constraint_union { my $name = shift; _create_type_constraint_union($name, \@_); } sub _create_type_constraint_union { my $name; $name = shift if @_ > 1; my @tcs = @{ shift() }; my @type_constraint_names; if ( scalar @tcs == 1 && _detect_type_constraint_union( $tcs[0] ) ) { @type_constraint_names = _parse_type_constraint_union( $tcs[0] ); } else { @type_constraint_names = @tcs; } ( scalar @type_constraint_names >= 2 ) || __PACKAGE__->_throw_error( "You must pass in at least 2 type names to make a union"); my @type_constraints = map { find_or_parse_type_constraint($_) || __PACKAGE__->_throw_error( "Could not locate type constraint ($_) for the union"); } @type_constraint_names; my %options = ( type_constraints => \@type_constraints ); $options{name} = $name if defined $name; return Moose::Meta::TypeConstraint::Union->new(%options); } sub create_parameterized_type_constraint { my $type_constraint_name = shift; my ( $base_type, $type_parameter ) = _parse_parameterized_type_constraint($type_constraint_name); ( defined $base_type && defined $type_parameter ) || __PACKAGE__->_throw_error( "Could not parse type name ($type_constraint_name) correctly"); if ( $REGISTRY->has_type_constraint($base_type) ) { my $base_type_tc = $REGISTRY->get_type_constraint($base_type); return _create_parameterized_type_constraint( $base_type_tc, $type_parameter ); } else { __PACKAGE__->_throw_error( "Could not locate the base type ($base_type)"); } } sub _create_parameterized_type_constraint { my ( $base_type_tc, $type_parameter ) = @_; if ( $base_type_tc->can('parameterize') ) { return $base_type_tc->parameterize($type_parameter); } else { return Moose::Meta::TypeConstraint::Parameterized->new( name => $base_type_tc->name . '[' . $type_parameter . ']', parent => $base_type_tc, type_parameter => find_or_create_isa_type_constraint($type_parameter), ); } } #should we also support optimized checks? sub create_class_type_constraint { my ( $class, $options ) = @_; # too early for this check #find_type_constraint("ClassName")->check($class) # || __PACKAGE__->_throw_error("Can't create a class type constraint because '$class' is not a class name"); my $pkg_defined_in = $options->{package_defined_in} || scalar( caller(1) ); if (my $type = $REGISTRY->get_type_constraint($class)) { if (!($type->isa('Moose::Meta::TypeConstraint::Class') && $type->class eq $class)) { _confess( "The type constraint '$class' has already been created in " . $type->_package_defined_in . " and cannot be created again in " . $pkg_defined_in ) } else { return $type; } } my %options = ( class => $class, name => $class, package_defined_in => $pkg_defined_in, %{ $options || {} }, ); $options{name} ||= "__ANON__"; my $tc = Moose::Meta::TypeConstraint::Class->new(%options); $REGISTRY->add_type_constraint($tc); return $tc; } sub create_role_type_constraint { my ( $role, $options ) = @_; # too early for this check #find_type_constraint("ClassName")->check($class) # || __PACKAGE__->_throw_error("Can't create a class type constraint because '$class' is not a class name"); my $pkg_defined_in = $options->{package_defined_in} || scalar( caller(1) ); if (my $type = $REGISTRY->get_type_constraint($role)) { if (!($type->isa('Moose::Meta::TypeConstraint::Role') && $type->role eq $role)) { _confess( "The type constraint '$role' has already been created in " . $type->_package_defined_in . " and cannot be created again in " . $pkg_defined_in ) } else { return $type; } } my %options = ( role => $role, name => $role, package_defined_in => $pkg_defined_in, %{ $options || {} }, ); $options{name} ||= "__ANON__"; my $tc = Moose::Meta::TypeConstraint::Role->new(%options); $REGISTRY->add_type_constraint($tc); return $tc; } sub find_or_create_type_constraint { my ( $type_constraint_name, $options_for_anon_type ) = @_; if ( my $constraint = find_or_parse_type_constraint($type_constraint_name) ) { return $constraint; } elsif ( defined $options_for_anon_type ) { # NOTE: # if there is no $options_for_anon_type # specified, then we assume they don't # want to create one, and return nothing. # otherwise assume that we should create # an ANON type with the $options_for_anon_type # options which can be passed in. It should # be noted that these don't get registered # so we need to return it. # - SL return Moose::Meta::TypeConstraint->new( name => '__ANON__', %{$options_for_anon_type} ); } return; } sub find_or_create_isa_type_constraint { my ($type_constraint_name, $options) = @_; find_or_parse_type_constraint($type_constraint_name) || create_class_type_constraint($type_constraint_name, $options); } sub find_or_create_does_type_constraint { my ($type_constraint_name, $options) = @_; find_or_parse_type_constraint($type_constraint_name) || create_role_type_constraint($type_constraint_name, $options); } sub find_or_parse_type_constraint { my $type_constraint_name = normalize_type_constraint_name(shift); my $constraint; if ( $constraint = find_type_constraint($type_constraint_name) ) { return $constraint; } elsif ( _detect_type_constraint_union($type_constraint_name) ) { $constraint = create_type_constraint_union($type_constraint_name); } elsif ( _detect_parameterized_type_constraint($type_constraint_name) ) { $constraint = create_parameterized_type_constraint($type_constraint_name); } else { return; } $REGISTRY->add_type_constraint($constraint); return $constraint; } sub normalize_type_constraint_name { my $type_constraint_name = shift; $type_constraint_name =~ s/\s//g; return $type_constraint_name; } sub _confess { my $error = shift; local $Carp::CarpLevel = $Carp::CarpLevel + 1; Carp::confess($error); } ## -------------------------------------------------------- ## exported functions ... ## -------------------------------------------------------- sub find_type_constraint { my $type = shift; if ( blessed $type and $type->isa("Moose::Meta::TypeConstraint") ) { return $type; } else { return unless $REGISTRY->has_type_constraint($type); return $REGISTRY->get_type_constraint($type); } } sub register_type_constraint { my $constraint = shift; __PACKAGE__->_throw_error("can't register an unnamed type constraint") unless defined $constraint->name; $REGISTRY->add_type_constraint($constraint); return $constraint; } # type constructors sub type { my $name = shift; my %p = map { %{$_} } @_; return _create_type_constraint( $name, undef, $p{where}, $p{message}, $p{optimize_as}, $p{inline_as}, ); } sub subtype { if ( @_ == 1 && !ref $_[0] ) { __PACKAGE__->_throw_error( 'A subtype cannot consist solely of a name, it must have a parent' ); } # The blessed check is mostly to accommodate MooseX::Types, which # uses an object which overloads stringification as a type name. my $name = ref $_[0] && !blessed $_[0] ? undef : shift; my %p = map { %{$_} } @_; # subtype Str => where { ... }; if ( !exists $p{as} ) { $p{as} = $name; $name = undef; } return _create_type_constraint( $name, $p{as}, $p{where}, $p{message}, $p{optimize_as}, $p{inline_as}, ); } sub class_type { create_class_type_constraint(@_); } sub role_type ($;$) { create_role_type_constraint(@_); } sub maybe_type { my ($type_parameter) = @_; register_type_constraint( $REGISTRY->get_type_constraint('Maybe')->parameterize($type_parameter) ); } sub duck_type { my ( $type_name, @methods ) = @_; if ( ref $type_name eq 'ARRAY' && !@methods ) { @methods = @$type_name; $type_name = undef; } if ( @methods == 1 && ref $methods[0] eq 'ARRAY' ) { @methods = @{ $methods[0] }; } register_type_constraint( create_duck_type_constraint( $type_name, \@methods, ) ); } sub coerce { my ( $type_name, @coercion_map ) = @_; _install_type_coercions( $type_name, \@coercion_map ); } # The trick of returning @_ lets us avoid having to specify a # prototype. Perl will parse this: # # subtype 'Foo' # => as 'Str' # => where { ... } # # as this: # # subtype( 'Foo', as( 'Str', where { ... } ) ); # # If as() returns all its extra arguments, this just works, and # preserves backwards compatibility. sub as { { as => shift }, @_ } sub where (&) { { where => $_[0] } } sub message (&) { { message => $_[0] } } sub optimize_as (&) { { optimize_as => $_[0] } } sub inline_as (&) { { inline_as => $_[0] } } sub from {@_} sub via (&) { $_[0] } sub enum { my ( $type_name, @values ) = @_; # NOTE: # if only an array-ref is passed then # you get an anon-enum # - SL if ( ref $type_name eq 'ARRAY' ) { @values == 0 || __PACKAGE__->_throw_error("enum called with an array reference and additional arguments. Did you mean to parenthesize the enum call's parameters?"); @values = @$type_name; $type_name = undef; } if ( @values == 1 && ref $values[0] eq 'ARRAY' ) { @values = @{ $values[0] }; } register_type_constraint( create_enum_type_constraint( $type_name, \@values, ) ); } sub union { my ( $type_name, @constraints ) = @_; if ( ref $type_name eq 'ARRAY' ) { @constraints == 0 || __PACKAGE__->_throw_error("union called with an array reference and additional arguments."); @constraints = @$type_name; $type_name = undef; } if ( @constraints == 1 && ref $constraints[0] eq 'ARRAY' ) { @constraints = @{ $constraints[0] }; } if ( defined $type_name ) { return register_type_constraint( create_named_type_constraint_union( $type_name, @constraints ) ); } return create_type_constraint_union( @constraints ); } sub create_enum_type_constraint { my ( $type_name, $values ) = @_; Moose::Meta::TypeConstraint::Enum->new( name => $type_name || '__ANON__', values => $values, ); } sub create_duck_type_constraint { my ( $type_name, $methods ) = @_; Moose::Meta::TypeConstraint::DuckType->new( name => $type_name || '__ANON__', methods => $methods, ); } sub match_on_type { my ($to_match, @cases) = @_; my $default; if (@cases % 2 != 0) { $default = pop @cases; (ref $default eq 'CODE') || __PACKAGE__->_throw_error("Default case must be a CODE ref, not $default"); } while (@cases) { my ($type, $action) = splice @cases, 0, 2; unless (blessed $type && $type->isa('Moose::Meta::TypeConstraint')) { $type = find_or_parse_type_constraint($type) || __PACKAGE__->_throw_error("Cannot find or parse the type '$type'") } (ref $action eq 'CODE') || __PACKAGE__->_throw_error("Match action must be a CODE ref, not $action"); if ($type->check($to_match)) { local $_ = $to_match; return $action->($to_match); } } (defined $default) || __PACKAGE__->_throw_error("No cases matched for $to_match"); { local $_ = $to_match; return $default->($to_match); } } ## -------------------------------------------------------- ## desugaring functions ... ## -------------------------------------------------------- sub _create_type_constraint ($$$;$$) { my $name = shift; my $parent = shift; my $check = shift; my $message = shift; my $optimized = shift; my $inlined = shift; my $pkg_defined_in = scalar( caller(1) ); if ( defined $name ) { my $type = $REGISTRY->get_type_constraint($name); ( $type->_package_defined_in eq $pkg_defined_in ) || _confess( "The type constraint '$name' has already been created in " . $type->_package_defined_in . " and cannot be created again in " . $pkg_defined_in ) if defined $type; $name =~ /^[\w:\.]+$/ or die qq{$name contains invalid characters for a type name.} . qq{ Names can contain alphanumeric character, ":", and "."\n}; } my %opts = ( name => $name, package_defined_in => $pkg_defined_in, ( $check ? ( constraint => $check ) : () ), ( $message ? ( message => $message ) : () ), ( $optimized ? ( optimized => $optimized ) : () ), ( $inlined ? ( inlined => $inlined ) : () ), ); my $constraint; if ( defined $parent and $parent = blessed $parent ? $parent : find_or_create_isa_type_constraint($parent) ) { $constraint = $parent->create_child_type(%opts); } else { $constraint = Moose::Meta::TypeConstraint->new(%opts); } $REGISTRY->add_type_constraint($constraint) if defined $name; return $constraint; } sub _install_type_coercions ($$) { my ( $type_name, $coercion_map ) = @_; my $type = find_type_constraint($type_name); ( defined $type ) || __PACKAGE__->_throw_error( "Cannot find type '$type_name', perhaps you forgot to load it"); if ( $type->has_coercion ) { $type->coercion->add_type_coercions(@$coercion_map); } else { my $type_coercion = Moose::Meta::TypeCoercion->new( type_coercion_map => $coercion_map, type_constraint => $type ); $type->coercion($type_coercion); } } ## -------------------------------------------------------- ## type notation parsing ... ## -------------------------------------------------------- { # All I have to say is mugwump++ cause I know # do not even have enough regexp-fu to be able # to have written this (I can only barely # understand it as it is) # - SL use re "eval"; my $valid_chars = qr{[\w:\.]}; my $type_atom = qr{ (?>$valid_chars+) }x; my $ws = qr{ (?>\s*) }x; my $op_union = qr{ $ws \| $ws }x; my ($type, $type_capture_parts, $type_with_parameter, $union, $any); if (Class::MOP::IS_RUNNING_ON_5_10) { my $type_pattern = q{ (?&type_atom) (?: \[ (?&ws) (?&any) (?&ws) \] )? }; my $type_capture_parts_pattern = q{ ((?&type_atom)) (?: \[ (?&ws) ((?&any)) (?&ws) \] )? }; my $type_with_parameter_pattern = q{ (?&type_atom) \[ (?&ws) (?&any) (?&ws) \] }; my $union_pattern = q{ (?&type) (?> (?: (?&op_union) (?&type) )+ ) }; my $any_pattern = q{ (?&type) | (?&union) }; my $defines = qr{(?(DEFINE) (? $valid_chars) (? $type_atom) (? $ws) (? $op_union) (? $type_pattern) (? $type_capture_parts_pattern) (? $type_with_parameter_pattern) (? $union_pattern) (? $any_pattern) )}x; $type = qr{ $type_pattern $defines }x; $type_capture_parts = qr{ $type_capture_parts_pattern $defines }x; $type_with_parameter = qr{ $type_with_parameter_pattern $defines }x; $union = qr{ $union_pattern $defines }x; $any = qr{ $any_pattern $defines }x; } else { $type = qr{ $type_atom (?: \[ $ws (??{$any}) $ws \] )? }x; $type_capture_parts = qr{ ($type_atom) (?: \[ $ws ((??{$any})) $ws \] )? }x; $type_with_parameter = qr{ $type_atom \[ $ws (??{$any}) $ws \] }x; $union = qr{ $type (?> (?: $op_union $type )+ ) }x; $any = qr{ $type | $union }x; } sub _parse_parameterized_type_constraint { { no warnings 'void'; $any; } # force capture of interpolated lexical $_[0] =~ m{ $type_capture_parts }x; return ( $1, $2 ); } sub _detect_parameterized_type_constraint { { no warnings 'void'; $any; } # force capture of interpolated lexical $_[0] =~ m{ ^ $type_with_parameter $ }x; } sub _parse_type_constraint_union { { no warnings 'void'; $any; } # force capture of interpolated lexical my $given = shift; my @rv; while ( $given =~ m{ \G (?: $op_union )? ($type) }gcx ) { push @rv => $1; } ( pos($given) eq length($given) ) || __PACKAGE__->_throw_error( "'$given' didn't parse (parse-pos=" . pos($given) . " and str-length=" . length($given) . ")" ); @rv; } sub _detect_type_constraint_union { { no warnings 'void'; $any; } # force capture of interpolated lexical $_[0] =~ m{^ $type $op_union $type ( $op_union .* )? $}x; } } ## -------------------------------------------------------- # define some basic built-in types ## -------------------------------------------------------- # By making these classes immutable before creating all the types in # Moose::Util::TypeConstraints::Builtin , we avoid repeatedly calling the slow # MOP-based accessors. $_->make_immutable( inline_constructor => 1, constructor_name => "_new", # these are Class::MOP accessors, so they need inlining inline_accessors => 1 ) for grep { $_->is_mutable } map { Class::MOP::class_of($_) } qw( Moose::Meta::TypeConstraint Moose::Meta::TypeConstraint::Union Moose::Meta::TypeConstraint::Parameterized Moose::Meta::TypeConstraint::Parameterizable Moose::Meta::TypeConstraint::Class Moose::Meta::TypeConstraint::Role Moose::Meta::TypeConstraint::Enum Moose::Meta::TypeConstraint::DuckType Moose::Meta::TypeConstraint::Registry ); require Moose::Util::TypeConstraints::Builtins; Moose::Util::TypeConstraints::Builtins::define_builtins($REGISTRY); my @PARAMETERIZABLE_TYPES = map { $REGISTRY->get_type_constraint($_) } qw[ScalarRef ArrayRef HashRef Maybe]; sub get_all_parameterizable_types {@PARAMETERIZABLE_TYPES} sub add_parameterizable_type { my $type = shift; ( blessed $type && $type->isa('Moose::Meta::TypeConstraint::Parameterizable') ) || __PACKAGE__->_throw_error( "Type must be a Moose::Meta::TypeConstraint::Parameterizable not $type" ); push @PARAMETERIZABLE_TYPES => $type; } ## -------------------------------------------------------- # end of built-in types ... ## -------------------------------------------------------- { my @BUILTINS = list_all_type_constraints(); sub list_all_builtin_type_constraints {@BUILTINS} } sub _throw_error { shift; require Moose; unshift @_, 'Moose'; goto &Moose::throw_error; } 1; # ABSTRACT: Type constraint system for Moose __END__ =pod =head1 NAME Moose::Util::TypeConstraints - Type constraint system for Moose =head1 VERSION version 2.1005 =head1 SYNOPSIS use Moose::Util::TypeConstraints; subtype 'Natural', as 'Int', where { $_ > 0 }; subtype 'NaturalLessThanTen', as 'Natural', where { $_ < 10 }, message { "This number ($_) is not less than ten!" }; coerce 'Num', from 'Str', via { 0+$_ }; class_type 'DateTimeClass', { class => 'DateTime' }; role_type 'Barks', { role => 'Some::Library::Role::Barks' }; enum 'RGBColors', [qw(red green blue)]; union 'StringOrArray', [qw( String Array )]; no Moose::Util::TypeConstraints; =head1 DESCRIPTION This module provides Moose with the ability to create custom type constraints to be used in attribute definition. =head2 Important Caveat This is B a type system for Perl 5. These are type constraints, and they are not used by Moose unless you tell it to. No type inference is performed, expressions are not typed, etc. etc. etc. A type constraint is at heart a small "check if a value is valid" function. A constraint can be associated with an attribute. This simplifies parameter validation, and makes your code clearer to read, because you can refer to constraints by name. =head2 Slightly Less Important Caveat It is B a good idea to quote your type names. This prevents Perl from trying to execute the call as an indirect object call. This can be an issue when you have a subtype with the same name as a valid class. For instance: subtype DateTime => as Object => where { $_->isa('DateTime') }; will I, while this: use DateTime; subtype DateTime => as Object => where { $_->isa('DateTime') }; will fail silently and cause many headaches. The simple way to solve this, as well as future proof your subtypes from classes which have yet to have been created, is to quote the type name: use DateTime; subtype 'DateTime', as 'Object', where { $_->isa('DateTime') }; =head2 Default Type Constraints This module also provides a simple hierarchy for Perl 5 types, here is that hierarchy represented visually. Any Item Bool Maybe[`a] Undef Defined Value Str Num Int ClassName RoleName Ref ScalarRef[`a] ArrayRef[`a] HashRef[`a] CodeRef RegexpRef GlobRef FileHandle Object B Any type followed by a type parameter C<[`a]> can be parameterized, this means you can say: ArrayRef[Int] # an array of integers HashRef[CodeRef] # a hash of str to CODE ref mappings ScalarRef[Int] # a reference to an integer Maybe[Str] # value may be a string, may be undefined If Moose finds a name in brackets that it does not recognize as an existing type, it assumes that this is a class name, for example C. B Unless you parameterize a type, then it is invalid to include the square brackets. I.e. C will be treated as a new type name, I as a parameterization of C. B The C type constraint for the most part works correctly now, but edge cases may still exist, please use it sparingly. B The C type constraint does a complex package existence check. This means that your class B be loaded for this type constraint to pass. B The C constraint checks a string is a I which is a role, like C<'MyApp::Role::Comparable'>. =head2 Type Constraint Naming Type name declared via this module can only contain alphanumeric characters, colons (:), and periods (.). Since the types created by this module are global, it is suggested that you namespace your types just as you would namespace your modules. So instead of creating a I type for your B module, you would call the type I instead. =head2 Use with Other Constraint Modules This module can play nicely with other constraint modules with some slight tweaking. The C clause in types is expected to be a C reference which checks its first argument and returns a boolean. Since most constraint modules work in a similar way, it should be simple to adapt them to work with Moose. For instance, this is how you could use it with L to declare a completely new type. type 'HashOfArrayOfObjects', where { IsHashRef( -keys => HasLength, -values => IsArrayRef(IsObject) )->(@_); }; For more examples see the F test file. Here is an example of using L and its non-test related C function. type 'ArrayOfHashOfBarsAndRandomNumbers', where { eq_deeply($_, array_each(subhashof({ bar => isa('Bar'), random_number => ignore() }))) }; For a complete example see the F test file. =head2 Error messages Type constraints can also specify custom error messages, for when they fail to validate. This is provided as just another coderef, which receives the invalid value in C<$_>, as in: subtype 'PositiveInt', as 'Int', where { $_ > 0 }, message { "$_ is not a positive integer!" }; If no message is specified, a default message will be used, which indicates which type constraint was being used and what value failed. If L (version 0.14 or higher) is installed, it will be used to display the invalid value, otherwise it will just be printed as is. =head1 FUNCTIONS =head2 Type Constraint Constructors The following functions are used to create type constraints. They will also register the type constraints your create in a global registry that is used to look types up by name. See the L for an example of how to use these. =over 4 =item B<< subtype 'Name', as 'Parent', where { } ... >> This creates a named subtype. If you provide a parent that Moose does not recognize, it will automatically create a new class type constraint for this name. When creating a named type, the C function should either be called with the sugar helpers (C, C, etc), or with a name and a hashref of parameters: subtype( 'Foo', { where => ..., message => ... } ); The valid hashref keys are C (the parent), C, C, and C. =item B<< subtype as 'Parent', where { } ... >> This creates an unnamed subtype and will return the type constraint meta-object, which will be an instance of L. When creating an anonymous type, the C function should either be called with the sugar helpers (C, C, etc), or with just a hashref of parameters: subtype( { where => ..., message => ... } ); =item B Creates a new subtype of C with the name C<$class> and the metaclass L. # Create a type called 'Box' which tests for objects which ->isa('Box') class_type 'Box'; By default, the name of the type and the name of the class are the same, but you can specify both separately. # Create a type called 'Box' which tests for objects which ->isa('ObjectLibrary::Box'); class_type 'Box', { class => 'ObjectLibrary::Box' }; =item B Creates a C type constraint with the name C<$role> and the metaclass L. # Create a type called 'Walks' which tests for objects which ->does('Walks') role_type 'Walks'; By default, the name of the type and the name of the role are the same, but you can specify both separately. # Create a type called 'Walks' which tests for objects which ->does('MooseX::Role::Walks'); role_type 'Walks', { role => 'MooseX::Role::Walks' }; =item B Creates a type constraint for either C or something of the given type. =item B This will create a subtype of Object and test to make sure the value C do the methods in C<\@methods>. This is intended as an easy way to accept non-Moose objects that provide a certain interface. If you're using Moose classes, we recommend that you use a C-only Role instead. =item B If passed an ARRAY reference as the only parameter instead of the C<$name>, C<\@methods> pair, this will create an unnamed duck type. This can be used in an attribute definition like so: has 'cache' => ( is => 'ro', isa => duck_type( [qw( get_set )] ), ); =item B This will create a basic subtype for a given set of strings. The resulting constraint will be a subtype of C and will match any of the items in C<\@values>. It is case sensitive. See the L for a simple example. B This is not a true proper enum type, it is simply a convenient constraint builder. =item B If passed an ARRAY reference as the only parameter instead of the C<$name>, C<\@values> pair, this will create an unnamed enum. This can then be used in an attribute definition like so: has 'sort_order' => ( is => 'ro', isa => enum([qw[ ascending descending ]]), ); =item B This will create a basic subtype where any of the provided constraints may match in order to satisfy this constraint. =item B If passed an ARRAY reference as the only parameter instead of the C<$name>, C<\@constraints> pair, this will create an unnamed union. This can then be used in an attribute definition like so: has 'items' => ( is => 'ro', isa => union([qw[ Str ArrayRef ]]), ); This is similar to the existing string union: isa => 'Str|ArrayRef' except that it supports anonymous elements as child constraints: has 'color' => ( isa => 'ro', isa => union([ 'Int', enum([qw[ red green blue ]]) ]), ); =item B This is just sugar for the type constraint construction syntax. It takes a single argument, which is the name of a parent type. =item B This is just sugar for the type constraint construction syntax. It takes a subroutine reference as an argument. When the type constraint is tested, the reference is run with the value to be tested in C<$_>. This reference should return true or false to indicate whether or not the constraint check passed. =item B This is just sugar for the type constraint construction syntax. It takes a subroutine reference as an argument. When the type constraint fails, then the code block is run with the value provided in C<$_>. This reference should return a string, which will be used in the text of the exception thrown. =item B This can be used to define a "hand optimized" inlinable version of your type constraint. You provide a subroutine which will be called I on a L object. It will receive a single parameter, the name of the variable to check, typically something like C<"$_"> or C<"$_[0]">. The subroutine should return a code string suitable for inlining. You can assume that the check will be wrapped in parentheses when it is inlined. The inlined code should include any checks that your type's parent types do. If your parent type constraint defines its own inlining, you can simply use that to avoid repeating code. For example, here is the inlining code for the C type, which is a subtype of C: sub { $_[0]->parent()->_inline_check($_[1]) . ' && !ref(' . $_[1] . ')' } =item B B instead.> This can be used to define a "hand optimized" version of your type constraint which can be used to avoid traversing a subtype constraint hierarchy. B You should only use this if you know what you are doing. All the built in types use this, so your subtypes (assuming they are shallow) will not likely need to use this. =item B<< type 'Name', where { } ... >> This creates a base type, which has no parent. The C function should either be called with the sugar helpers (C, C, etc), or with a name and a hashref of parameters: type( 'Foo', { where => ..., message => ... } ); The valid hashref keys are C, C, and C. =back =head2 Type Constraint Utilities =over 4 =item B<< match_on_type $value => ( $type => \&action, ... ?\&default ) >> This is a utility function for doing simple type based dispatching similar to match/case in OCaml and case/of in Haskell. It is not as featureful as those languages, nor does not it support any kind of automatic destructuring bind. Here is a simple Perl pretty printer dispatching over the core Moose types. sub ppprint { my $x = shift; match_on_type $x => ( HashRef => sub { my $hash = shift; '{ ' . ( join ", " => map { $_ . ' => ' . ppprint( $hash->{$_} ) } sort keys %$hash ) . ' }'; }, ArrayRef => sub { my $array = shift; '[ ' . ( join ", " => map { ppprint($_) } @$array ) . ' ]'; }, CodeRef => sub {'sub { ... }'}, RegexpRef => sub { 'qr/' . $_ . '/' }, GlobRef => sub { '*' . B::svref_2object($_)->NAME }, Object => sub { $_->can('to_string') ? $_->to_string : $_ }, ScalarRef => sub { '\\' . ppprint( ${$_} ) }, Num => sub {$_}, Str => sub { '"' . $_ . '"' }, Undef => sub {'undef'}, => sub { die "I don't know what $_ is" } ); } Or a simple JSON serializer: sub to_json { my $x = shift; match_on_type $x => ( HashRef => sub { my $hash = shift; '{ ' . ( join ", " => map { '"' . $_ . '" : ' . to_json( $hash->{$_} ) } sort keys %$hash ) . ' }'; }, ArrayRef => sub { my $array = shift; '[ ' . ( join ", " => map { to_json($_) } @$array ) . ' ]'; }, Num => sub {$_}, Str => sub { '"' . $_ . '"' }, Undef => sub {'null'}, => sub { die "$_ is not acceptable json type" } ); } The matcher is done by mapping a C<$type> to an C<\&action>. The C<$type> can be either a string type or a L object, and C<\&action> is a subroutine reference. This function will dispatch on the first match for C<$value>. It is possible to have a catch-all by providing an additional subroutine reference as the final argument to C. =back =head2 Type Coercion Constructors You can define coercions for type constraints, which allow you to automatically transform values to something valid for the type constraint. If you ask your accessor to coerce, then Moose will run the type-coercion code first, followed by the type constraint check. This feature should be used carefully as it is very powerful and could easily take off a limb if you are not careful. See the L for an example of how to use these. =over 4 =item B<< coerce 'Name', from 'OtherName', via { ... } >> This defines a coercion from one type to another. The C argument is the type you are coercing I. To define multiple coercions, supply more sets of from/via pairs: coerce 'Name', from 'OtherName', via { ... }, from 'ThirdName', via { ... }; =item B This is just sugar for the type coercion construction syntax. It takes a single type name (or type object), which is the type being coerced I. =item B This is just sugar for the type coercion construction syntax. It takes a subroutine reference. This reference will be called with the value to be coerced in C<$_>. It is expected to return a new value of the proper type for the coercion. =back =head2 Creating and Finding Type Constraints These are additional functions for creating and finding type constraints. Most of these functions are not available for importing. The ones that are importable as specified. =over 4 =item B This function can be used to locate the L object for a named type. This function is importable. =item B This function will register a L with the global type registry. This function is importable. =item B This method takes a type constraint name and returns the normalized form. This removes any whitespace in the string. =item B =item B This can take a union type specification like C<'Int|ArrayRef[Int]'>, or a list of names. It returns a new L object. =item B Given a C<$type_name> in the form of C<'BaseType[ContainerType]'>, this will create a new L object. The C must exist already exist as a parameterizable type. =item B Given a class name this function will create a new L object for that class name. The C<$options> is a hash reference that will be passed to the L constructor (as a hash). =item B Given a role name this function will create a new L object for that role name. The C<$options> is a hash reference that will be passed to the L constructor (as a hash). =item B Given a enum name this function will create a new L object for that enum name. =item B Given a duck type name this function will create a new L object for that enum name. =item B Given a type name, this first attempts to find a matching constraint in the global registry. If the type name is a union or parameterized type, it will create a new object of the appropriate, but if given a "regular" type that does not yet exist, it simply returns false. When given a union or parameterized type, the member or base type must already exist. If it creates a new union or parameterized type, it will add it to the global registry. =item B =item B These functions will first call C. If that function does not return a type, a new type object will be created. The C variant will use C and the C variant will use C. =item B Returns the L object which keeps track of all type constraints. =item B This will return a list of type constraint names in the global registry. You can then fetch the actual type object using C. =item B This will return a list of builtin type constraints, meaning those which are defined in this module. See the L section for a complete list. =item B This will export all the current type constraints as functions into the caller's namespace (C, C, etc). Right now, this is mostly used for testing, but it might prove useful to others. =item B This returns all the parameterizable types that have been registered, as a list of type objects. =item B Adds C<$type> to the list of parameterizable types =back =head1 BUGS See L for details on reporting bugs. =head1 AUTHOR Moose is maintained by the Moose Cabal, along with the help of many contributors. See L and L for details. =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2013 by Infinity Interactive, Inc.. This is free software; you can redistribute it and/or modify it under the same terms as the Perl 5 programming language system itself. =cut attribute_required.t100644000767000024 324212200352345 21057 0ustar00etherstaff000000000000Moose-2.1005/t/attributes#!/usr/bin/perl use strict; use warnings; use Test::More; use Test::Fatal; { package Foo; use Moose; has 'bar' => (is => 'ro', required => 1); has 'baz' => (is => 'rw', default => 100, required => 1); has 'boo' => (is => 'rw', lazy => 1, default => 50, required => 1); } { my $foo = Foo->new(bar => 10, baz => 20, boo => 100); isa_ok($foo, 'Foo'); is($foo->bar, 10, '... got the right bar'); is($foo->baz, 20, '... got the right baz'); is($foo->boo, 100, '... got the right boo'); } { my $foo = Foo->new(bar => 10, boo => 5); isa_ok($foo, 'Foo'); is($foo->bar, 10, '... got the right bar'); is($foo->baz, 100, '... got the right baz'); is($foo->boo, 5, '... got the right boo'); } { my $foo = Foo->new(bar => 10); isa_ok($foo, 'Foo'); is($foo->bar, 10, '... got the right bar'); is($foo->baz, 100, '... got the right baz'); is($foo->boo, 50, '... got the right boo'); } #Yeah.. this doesn't work like this anymore, see below. (groditi) #throws_ok { # Foo->new(bar => 10, baz => undef); #} qr/^Attribute \(baz\) is required and cannot be undef/, '... must supply all the required attribute'; #throws_ok { # Foo->new(bar => 10, boo => undef); #} qr/^Attribute \(boo\) is required and cannot be undef/, '... must supply all the required attribute'; is( exception { Foo->new(bar => 10, baz => undef); }, undef, '... undef is a valid attribute value' ); is( exception { Foo->new(bar => 10, boo => undef); }, undef, '... undef is a valid attribute value' ); like( exception { Foo->new; }, qr/^Attribute \(bar\) is required/, '... must supply all the required attribute' ); done_testing; attribute_triggers.t100644000767000024 1362612200352345 21114 0ustar00etherstaff000000000000Moose-2.1005/t/attributes#!/usr/bin/perl use strict; use warnings; use Scalar::Util 'isweak'; use Test::More; use Test::Fatal; { package Foo; use Moose; has 'bar' => (is => 'rw', isa => 'Maybe[Bar]', trigger => sub { my ($self, $bar) = @_; $bar->foo($self) if defined $bar; }); has 'baz' => (writer => 'set_baz', reader => 'get_baz', isa => 'Baz', trigger => sub { my ($self, $baz) = @_; $baz->foo($self); }); package Bar; use Moose; has 'foo' => (is => 'rw', isa => 'Foo', weak_ref => 1); package Baz; use Moose; has 'foo' => (is => 'rw', isa => 'Foo', weak_ref => 1); } { my $foo = Foo->new; isa_ok($foo, 'Foo'); my $bar = Bar->new; isa_ok($bar, 'Bar'); my $baz = Baz->new; isa_ok($baz, 'Baz'); is( exception { $foo->bar($bar); }, undef, '... did not die setting bar' ); is($foo->bar, $bar, '... set the value foo.bar correctly'); is($bar->foo, $foo, '... which in turn set the value bar.foo correctly'); ok(isweak($bar->{foo}), '... bar.foo is a weak reference'); is( exception { $foo->bar(undef); }, undef, '... did not die un-setting bar' ); is($foo->bar, undef, '... set the value foo.bar correctly'); is($bar->foo, $foo, '... which in turn set the value bar.foo correctly'); # test the writer is( exception { $foo->set_baz($baz); }, undef, '... did not die setting baz' ); is($foo->get_baz, $baz, '... set the value foo.baz correctly'); is($baz->foo, $foo, '... which in turn set the value baz.foo correctly'); ok(isweak($baz->{foo}), '... baz.foo is a weak reference'); } { my $bar = Bar->new; isa_ok($bar, 'Bar'); my $baz = Baz->new; isa_ok($baz, 'Baz'); my $foo = Foo->new(bar => $bar, baz => $baz); isa_ok($foo, 'Foo'); is($foo->bar, $bar, '... set the value foo.bar correctly'); is($bar->foo, $foo, '... which in turn set the value bar.foo correctly'); ok(isweak($bar->{foo}), '... bar.foo is a weak reference'); is($foo->get_baz, $baz, '... set the value foo.baz correctly'); is($baz->foo, $foo, '... which in turn set the value baz.foo correctly'); ok(isweak($baz->{foo}), '... baz.foo is a weak reference'); } # some errors { package Bling; use Moose; ::isnt( ::exception { has('bling' => (is => 'rw', trigger => 'Fail')); }, undef, '... a trigger must be a CODE ref' ); ::isnt( ::exception { has('bling' => (is => 'rw', trigger => [])); }, undef, '... a trigger must be a CODE ref' ); } # Triggers do not fire on built values { package Blarg; use Moose; our %trigger_calls; our %trigger_vals; has foo => (is => 'rw', default => sub { 'default foo value' }, trigger => sub { my ($self, $val, $attr) = @_; $trigger_calls{foo}++; $trigger_vals{foo} = $val }); has bar => (is => 'rw', lazy_build => 1, trigger => sub { my ($self, $val, $attr) = @_; $trigger_calls{bar}++; $trigger_vals{bar} = $val }); sub _build_bar { return 'default bar value' } has baz => (is => 'rw', builder => '_build_baz', trigger => sub { my ($self, $val, $attr) = @_; $trigger_calls{baz}++; $trigger_vals{baz} = $val }); sub _build_baz { return 'default baz value' } } { my $blarg; is( exception { $blarg = Blarg->new; }, undef, 'Blarg->new() lives' ); ok($blarg, 'Have a $blarg'); foreach my $attr (qw/foo bar baz/) { is($blarg->$attr(), "default $attr value", "$attr has default value"); } is_deeply(\%Blarg::trigger_calls, {}, 'No triggers fired'); foreach my $attr (qw/foo bar baz/) { $blarg->$attr("Different $attr value"); } is_deeply(\%Blarg::trigger_calls, { map { $_ => 1 } qw/foo bar baz/ }, 'All triggers fired once on assign'); is_deeply(\%Blarg::trigger_vals, { map { $_ => "Different $_ value" } qw/foo bar baz/ }, 'All triggers given assigned values'); is( exception { $blarg => Blarg->new( map { $_ => "Yet another $_ value" } qw/foo bar baz/ ) }, undef, '->new() with parameters' ); is_deeply(\%Blarg::trigger_calls, { map { $_ => 2 } qw/foo bar baz/ }, 'All triggers fired once on construct'); is_deeply(\%Blarg::trigger_vals, { map { $_ => "Yet another $_ value" } qw/foo bar baz/ }, 'All triggers given assigned values'); } # Triggers do not receive the meta-attribute as an argument, but do # receive the old value { package Foo; use Moose; our @calls; has foo => (is => 'rw', trigger => sub { push @calls, [@_] }); } { my $attr = Foo->meta->get_attribute('foo'); my $foo = Foo->new; $attr->set_value( $foo, 2 ); is_deeply( \@Foo::calls, [ [ $foo, 2 ] ], 'trigger called correctly on initial set via meta-API', ); @Foo::calls = (); $attr->set_value( $foo, 3 ); is_deeply( \@Foo::calls, [ [ $foo, 3, 2 ] ], 'trigger called correctly on second set via meta-API', ); @Foo::calls = (); $attr->set_raw_value( $foo, 4 ); is_deeply( \@Foo::calls, [ ], 'trigger not called using set_raw_value method', ); @Foo::calls = (); } { my $foo = Foo->new(foo => 2); is_deeply( \@Foo::calls, [ [ $foo, 2 ] ], 'trigger called correctly on construction', ); @Foo::calls = (); $foo->foo(3); is_deeply( \@Foo::calls, [ [ $foo, 3, 2 ] ], 'trigger called correctly on set (with old value)', ); @Foo::calls = (); Foo->meta->make_immutable, redo if Foo->meta->is_mutable; } done_testing; inherit_lazy_build.t100644000767000024 307112200352345 21034 0ustar00etherstaff000000000000Moose-2.1005/t/attributesuse strict; use warnings; use Test::More; { package Parent; use Moose; has attr => ( is => 'rw', isa => 'Str' ); } { package Child; use Moose; extends 'Parent'; has '+attr' => ( lazy_build => 1 ); sub _build_attr { return 'value'; } } my $parent = Parent->new(); my $child = Child->new(); ok( !$parent->meta->get_attribute('attr')->is_lazy_build, 'attribute in parent does not have lazy_build trait' ); ok( !$parent->meta->get_attribute('attr')->is_lazy, 'attribute in parent does not have lazy trait' ); ok( !$parent->meta->get_attribute('attr')->has_builder, 'attribute in parent does not have a builder method' ); ok( !$parent->meta->get_attribute('attr')->has_clearer, 'attribute in parent does not have a clearer method' ); ok( !$parent->meta->get_attribute('attr')->has_predicate, 'attribute in parent does not have a predicate method' ); ok( $child->meta->get_attribute('attr')->is_lazy_build, 'attribute in child has the lazy_build trait' ); ok( $child->meta->get_attribute('attr')->is_lazy, 'attribute in child has the lazy trait' ); ok( $child->meta->get_attribute('attr')->has_builder, 'attribute in child has a builder method' ); ok( $child->meta->get_attribute('attr')->has_clearer, 'attribute in child has a clearer method' ); ok( $child->meta->get_attribute('attr')->has_predicate, 'attribute in child has a predicate method' ); is( $child->attr, 'value', 'attribute defined as lazy_build in child is properly built' ); done_testing; trigger_and_coerce.t100644000767000024 224012200352345 20756 0ustar00etherstaff000000000000Moose-2.1005/t/attributes#!/usr/bin/perl use strict; use warnings; use Test::More; { package Fake::DateTime; use Moose; has 'string_repr' => ( is => 'ro' ); package Mortgage; use Moose; use Moose::Util::TypeConstraints; coerce 'Fake::DateTime' => from 'Str' => via { Fake::DateTime->new( string_repr => $_ ) }; has 'closing_date' => ( is => 'rw', isa => 'Fake::DateTime', coerce => 1, trigger => sub { my ( $self, $val ) = @_; ::pass('... trigger is being called'); ::isa_ok( $self->closing_date, 'Fake::DateTime' ); ::isa_ok( $val, 'Fake::DateTime' ); } ); } { my $mtg = Mortgage->new( closing_date => 'yesterday' ); isa_ok( $mtg, 'Mortgage' ); # check that coercion worked isa_ok( $mtg->closing_date, 'Fake::DateTime' ); } Mortgage->meta->make_immutable; ok( Mortgage->meta->is_immutable, '... Mortgage is now immutable' ); { my $mtg = Mortgage->new( closing_date => 'yesterday' ); isa_ok( $mtg, 'Mortgage' ); # check that coercion worked isa_ok( $mtg->closing_date, 'Fake::DateTime' ); } done_testing; always_strict_warnings.t100644000767000024 334612200352345 21037 0ustar00etherstaff000000000000Moose-2.1005/t/basics#!/usr/bin/perl use Test::More; # for classes ... { package Foo; use Moose; eval '$foo = 5;'; ::ok($@, '... got an error because strict is on'); ::like($@, qr/Global symbol \"\$foo\" requires explicit package name at/, '... got the right error'); { my $warn; local $SIG{__WARN__} = sub { $warn = $_[0] }; ::ok(!$warn, '... no warning yet'); eval 'my $bar = 1 + "hello"'; ::ok($warn, '... got a warning'); ::like($warn, qr/Argument \"hello\" isn\'t numeric in addition \(\+\)/, '.. and it is the right warning'); } } # and for roles ... { package Bar; use Moose::Role; eval '$foo = 5;'; ::ok($@, '... got an error because strict is on'); ::like($@, qr/Global symbol \"\$foo\" requires explicit package name at/, '... got the right error'); { my $warn; local $SIG{__WARN__} = sub { $warn = $_[0] }; ::ok(!$warn, '... no warning yet'); eval 'my $bar = 1 + "hello"'; ::ok($warn, '... got a warning'); ::like($warn, qr/Argument \"hello\" isn\'t numeric in addition \(\+\)/, '.. and it is the right warning'); } } # and for exporters { package Bar; use Moose::Exporter; eval '$foo = 5;'; ::ok($@, '... got an error because strict is on'); ::like($@, qr/Global symbol \"\$foo\" requires explicit package name at/, '... got the right error'); { my $warn; local $SIG{__WARN__} = sub { $warn = $_[0] }; ::ok(!$warn, '... no warning yet'); eval 'my $bar = 1 + "hello"'; ::ok($warn, '... got a warning'); ::like($warn, qr/Argument \"hello\" isn\'t numeric in addition \(\+\)/, '.. and it is the right warning'); } } done_testing; DEMOLISH_eats_exceptions.t100644000767000024 754312200352345 20417 0ustar00etherstaff000000000000Moose-2.1005/t/bugs#!/usr/bin/perl use strict; use warnings; use FindBin; use Test::More; use Moose::Util::TypeConstraints; subtype 'FilePath' => as 'Str' # This used to try to _really_ check for a valid Unix or Windows # path, but the regex wasn't quite right, and all we care about # for the tests is that it rejects '/' => where { $_ ne '/' }; { package Baz; use Moose; use Moose::Util::TypeConstraints; has 'path' => ( is => 'ro', isa => 'FilePath', required => 1, ); sub BUILD { my ( $self, $params ) = @_; confess $params->{path} . " does not exist" unless -e $params->{path}; } # Defining this causes the FIRST call to Baz->new w/o param to fail, # if no call to ANY Moose::Object->new was done before. sub DEMOLISH { my ( $self ) = @_; } } { package Qee; use Moose; use Moose::Util::TypeConstraints; has 'path' => ( is => 'ro', isa => 'FilePath', required => 1, ); sub BUILD { my ( $self, $params ) = @_; confess $params->{path} . " does not exist" unless -e $params->{path}; } # Defining this causes the FIRST call to Qee->new w/o param to fail... # if no call to ANY Moose::Object->new was done before. sub DEMOLISH { my ( $self ) = @_; } } { package Foo; use Moose; use Moose::Util::TypeConstraints; has 'path' => ( is => 'ro', isa => 'FilePath', required => 1, ); sub BUILD { my ( $self, $params ) = @_; confess $params->{path} . " does not exist" unless -e $params->{path}; } # Having no DEMOLISH, everything works as expected... } check_em ( 'Baz' ); # 'Baz plain' will fail, aka NO error check_em ( 'Qee' ); # ok check_em ( 'Foo' ); # ok check_em ( 'Qee' ); # 'Qee plain' will fail, aka NO error check_em ( 'Baz' ); # ok check_em ( 'Foo' ); # ok check_em ( 'Foo' ); # ok check_em ( 'Baz' ); # ok ! check_em ( 'Qee' ); # ok sub check_em { my ( $pkg ) = @_; my ( %param, $obj ); # Uncomment to see, that it is really any first call. # Subsequents calls will not fail, aka giving the correct error. { local $@; my $obj = eval { $pkg->new; }; ::like( $@, qr/is required/, "... $pkg plain" ); ::is( $obj, undef, "... the object is undef" ); } { local $@; my $obj = eval { $pkg->new(); }; ::like( $@, qr/is required/, "... $pkg empty" ); ::is( $obj, undef, "... the object is undef" ); } { local $@; my $obj = eval { $pkg->new ( notanattr => 1 ); }; ::like( $@, qr/is required/, "... $pkg undef" ); ::is( $obj, undef, "... the object is undef" ); } { local $@; my $obj = eval { $pkg->new ( %param ); }; ::like( $@, qr/is required/, "... $pkg undef param" ); ::is( $obj, undef, "... the object is undef" ); } { local $@; my $obj = eval { $pkg->new ( path => '/' ); }; ::like( $@, qr/does not pass the type constraint/, "... $pkg root path forbidden" ); ::is( $obj, undef, "... the object is undef" ); } { local $@; my $obj = eval { $pkg->new ( path => '/this_path/does/not_exist' ); }; ::like( $@, qr/does not exist/, "... $pkg non existing path" ); ::is( $obj, undef, "... the object is undef" ); } { local $@; my $obj = eval { $pkg->new ( path => $FindBin::Bin ); }; ::is( $@, '', "... $pkg no error" ); ::isa_ok( $obj, $pkg ); ::isa_ok( $obj, 'Moose::Object' ); ::is( $obj->path, $FindBin::Bin, "... $pkg got the right value" ); } } done_testing; lazybuild_required_undef.t100644000767000024 144512200352345 21011 0ustar00etherstaff000000000000Moose-2.1005/t/bugspackage Foo; use Moose; ## Problem: ## lazy_build sets required => 1 ## required does not permit setting to undef ## Possible solutions: #### remove required => 1 #### check the attr to see if it accepts Undef (Maybe[], | Undef) #### or, make required accept undef and use a predicate test has 'foo' => ( isa => 'Int | Undef', is => 'rw', lazy_build => 1 ); has 'bar' => ( isa => 'Int | Undef', is => 'rw' ); sub _build_foo { undef } package main; use Test::More; ok ( !defined(Foo->new->bar), 'NonLazyBuild: Undef default' ); ok ( !defined(Foo->new->bar(undef)), 'NonLazyBuild: Undef explicit' ); ok ( !defined(Foo->new->foo), 'LazyBuild: Undef default/lazy_build' ); ## This test fails at the time of creation. ok ( !defined(Foo->new->foo(undef)), 'LazyBuild: Undef explicit' ); done_testing; type_constraint_messages.t100644000767000024 305312200352345 21042 0ustar00etherstaff000000000000Moose-2.1005/t/bugs#!/usr/bin/perl use strict; use warnings; use Test::More; use Test::Fatal; # RT #37569 { package MyObject; use Moose; package Foo; use Moose; use Moose::Util::TypeConstraints; subtype 'MyArrayRef' => as 'ArrayRef' => where { defined $_->[0] } => message { ref $_ ? "ref: ". ref $_ : 'scalar' } # stringy ; subtype 'MyObjectType' => as 'Object' => where { $_->isa('MyObject') } => message { if ( $_->isa('SomeObject') ) { return 'More detailed error message'; } elsif ( blessed $_ ) { return 'Well it is an object'; } else { return 'Doh!'; } } ; type 'NewType' => where { $_->isa('MyObject') } => message { blessed $_ ? 'blessed' : 'scalar' } ; has 'obj' => ( is => 'rw', isa => 'MyObjectType' ); has 'ar' => ( is => 'rw', isa => 'MyArrayRef' ); has 'nt' => ( is => 'rw', isa => 'NewType' ); } my $foo = Foo->new; my $obj = MyObject->new; like( exception { $foo->ar( [] ); }, qr/Attribute \(ar\) does not pass the type constraint because: ref: ARRAY/, '... got the right error message' ); like( exception { $foo->obj($foo); # Doh! }, qr/Attribute \(obj\) does not pass the type constraint because: Well it is an object/, '... got the right error message' ); like( exception { $foo->nt($foo); # scalar }, qr/Attribute \(nt\) does not pass the type constraint because: blessed/, '... got the right error message' ); done_testing; attribute_get_read_write.t100644000767000024 716012200352345 20776 0ustar00etherstaff000000000000Moose-2.1005/t/cmopuse strict; use warnings; use Scalar::Util 'blessed', 'reftype'; use Test::More; use Class::MOP; =pod This checks the get_read/write_method and get_read/write_method_ref methods =cut { package Foo; use metaclass; Foo->meta->add_attribute('bar' => reader => 'get_bar', writer => 'set_bar', ); Foo->meta->add_attribute('baz' => accessor => 'baz', ); Foo->meta->add_attribute('gorch' => reader => { 'get_gorch', => sub { (shift)->{gorch} } } ); package Bar; use metaclass; Bar->meta->superclasses('Foo'); Bar->meta->add_attribute('quux' => accessor => 'quux', ); } can_ok('Foo', 'get_bar'); can_ok('Foo', 'set_bar'); can_ok('Foo', 'baz'); can_ok('Foo', 'get_gorch'); ok(Foo->meta->has_attribute('bar'), '... Foo has the attribute bar'); ok(Foo->meta->has_attribute('baz'), '... Foo has the attribute baz'); ok(Foo->meta->has_attribute('gorch'), '... Foo has the attribute gorch'); my $bar_attr = Foo->meta->get_attribute('bar'); my $baz_attr = Foo->meta->get_attribute('baz'); my $gorch_attr = Foo->meta->get_attribute('gorch'); is($bar_attr->reader, 'get_bar', '... the bar attribute has the reader get_bar'); is($bar_attr->writer, 'set_bar', '... the bar attribute has the writer set_bar'); is($bar_attr->associated_class, Foo->meta, '... and the bar attribute is associated with Foo->meta'); is($bar_attr->get_read_method, 'get_bar', '... $attr does have an read method'); is($bar_attr->get_write_method, 'set_bar', '... $attr does have an write method'); { my $reader = $bar_attr->get_read_method_ref; my $writer = $bar_attr->get_write_method_ref; isa_ok($reader, 'Class::MOP::Method'); isa_ok($writer, 'Class::MOP::Method'); is($reader->fully_qualified_name, 'Foo::get_bar', '... it is the sub we are looking for'); is($writer->fully_qualified_name, 'Foo::set_bar', '... it is the sub we are looking for'); is(reftype($reader->body), 'CODE', '... it is a plain old sub'); is(reftype($writer->body), 'CODE', '... it is a plain old sub'); } is($baz_attr->accessor, 'baz', '... the bar attribute has the accessor baz'); is($baz_attr->associated_class, Foo->meta, '... and the bar attribute is associated with Foo->meta'); is($baz_attr->get_read_method, 'baz', '... $attr does have an read method'); is($baz_attr->get_write_method, 'baz', '... $attr does have an write method'); { my $reader = $baz_attr->get_read_method_ref; my $writer = $baz_attr->get_write_method_ref; isa_ok($reader, 'Class::MOP::Method'); isa_ok($writer, 'Class::MOP::Method'); is($reader, $writer, '... they are the same method'); is($reader->fully_qualified_name, 'Foo::baz', '... it is the sub we are looking for'); is($writer->fully_qualified_name, 'Foo::baz', '... it is the sub we are looking for'); } is(ref($gorch_attr->reader), 'HASH', '... the gorch attribute has the reader get_gorch (HASH ref)'); is($gorch_attr->associated_class, Foo->meta, '... and the gorch attribute is associated with Foo->meta'); is($gorch_attr->get_read_method, 'get_gorch', '... $attr does have an read method'); ok(!$gorch_attr->get_write_method, '... $attr does not have an write method'); { my $reader = $gorch_attr->get_read_method_ref; my $writer = $gorch_attr->get_write_method_ref; isa_ok($reader, 'Class::MOP::Method'); ok(blessed($writer), '... it is not a plain old sub'); isa_ok($writer, 'Class::MOP::Method'); is($reader->fully_qualified_name, 'Foo::get_gorch', '... it is the sub we are looking for'); is($writer->fully_qualified_name, 'Foo::__ANON__', '... it is the sub we are looking for'); } done_testing; attribute_non_alpha_name.t100644000767000024 120612200352345 20744 0ustar00etherstaff000000000000Moose-2.1005/t/cmopuse strict; use warnings; use Class::MOP; use Test::More; { package Foo; use metaclass; Foo->meta->add_attribute( '@foo', accessor => 'foo' ); Foo->meta->add_attribute( '!bar', reader => 'bar' ); Foo->meta->add_attribute( '%baz', reader => 'baz' ); } { my $meta = Foo->meta; for my $name ( '@foo', '!bar', '%baz' ) { ok( $meta->has_attribute($name), "Foo has $name attribute" ); my $meth = substr $name, 1; ok( $meta->has_method($meth), 'Foo has $meth method' ); } $meta->make_immutable, redo unless $meta->is_immutable; } done_testing; immutable_w_constructors.t100644000767000024 2065312200352345 21106 0ustar00etherstaff000000000000Moose-2.1005/t/cmopuse strict; use warnings; use Test::More; use Test::Fatal; use Class::MOP; { package Foo; use strict; use warnings; use metaclass; __PACKAGE__->meta->add_attribute('bar' => ( reader => 'bar', default => 'BAR', )); package Bar; use strict; use warnings; use metaclass; __PACKAGE__->meta->superclasses('Foo'); __PACKAGE__->meta->add_attribute('baz' => ( reader => 'baz', default => sub { 'BAZ' }, )); package Baz; use strict; use warnings; use metaclass; __PACKAGE__->meta->superclasses('Bar'); __PACKAGE__->meta->add_attribute('bah' => ( reader => 'bah', default => 'BAH', )); package Buzz; use strict; use warnings; use metaclass; __PACKAGE__->meta->add_attribute('bar' => ( accessor => 'bar', predicate => 'has_bar', clearer => 'clear_bar', )); __PACKAGE__->meta->add_attribute('bah' => ( accessor => 'bah', predicate => 'has_bah', clearer => 'clear_bah', default => 'BAH' )); } { my $meta = Foo->meta; is($meta->name, 'Foo', '... checking the Foo metaclass'); { my $bar_accessor = $meta->get_method('bar'); isa_ok($bar_accessor, 'Class::MOP::Method::Accessor'); isa_ok($bar_accessor, 'Class::MOP::Method'); ok(!$bar_accessor->is_inline, '... the bar accessor is not inlined'); } ok(!$meta->is_immutable, '... our class is not immutable'); is( exception { $meta->make_immutable( inline_constructor => 1, inline_accessors => 0, ); }, undef, '... changed Foo to be immutable' ); ok($meta->is_immutable, '... our class is now immutable'); isa_ok($meta, 'Class::MOP::Class'); # they made a constructor for us :) can_ok('Foo', 'new'); { my $foo = Foo->new; isa_ok($foo, 'Foo'); is($foo->bar, 'BAR', '... got the right default value'); } { my $foo = Foo->new(bar => 'BAZ'); isa_ok($foo, 'Foo'); is($foo->bar, 'BAZ', '... got the right parameter value'); } # NOTE: # check that the constructor correctly handles inheritance { my $bar = Bar->new(); isa_ok($bar, 'Bar'); isa_ok($bar, 'Foo'); is($bar->bar, 'BAR', '... got the right inherited parameter value'); is($bar->baz, 'BAZ', '... got the right inherited parameter value'); } # check out accessors too { my $bar_accessor = $meta->get_method('bar'); isa_ok($bar_accessor, 'Class::MOP::Method::Accessor'); isa_ok($bar_accessor, 'Class::MOP::Method'); ok(!$bar_accessor->is_inline, '... the bar accessor is still not inlined'); } } { my $meta = Bar->meta; is($meta->name, 'Bar', '... checking the Bar metaclass'); { my $bar_accessor = $meta->find_method_by_name('bar'); isa_ok($bar_accessor, 'Class::MOP::Method::Accessor'); isa_ok($bar_accessor, 'Class::MOP::Method'); ok(!$bar_accessor->is_inline, '... the bar accessor is not inlined'); my $baz_accessor = $meta->get_method('baz'); isa_ok($baz_accessor, 'Class::MOP::Method::Accessor'); isa_ok($baz_accessor, 'Class::MOP::Method'); ok(!$baz_accessor->is_inline, '... the baz accessor is not inlined'); } ok(!$meta->is_immutable, '... our class is not immutable'); is( exception { $meta->make_immutable( inline_constructor => 1, inline_accessors => 1, ); }, undef, '... changed Bar to be immutable' ); ok($meta->is_immutable, '... our class is now immutable'); isa_ok($meta, 'Class::MOP::Class'); # they made a constructor for us :) can_ok('Bar', 'new'); { my $bar = Bar->new; isa_ok($bar, 'Bar'); is($bar->bar, 'BAR', '... got the right default value'); is($bar->baz, 'BAZ', '... got the right default value'); } { my $bar = Bar->new(bar => 'BAZ!', baz => 'BAR!'); isa_ok($bar, 'Bar'); is($bar->bar, 'BAZ!', '... got the right parameter value'); is($bar->baz, 'BAR!', '... got the right parameter value'); } # check out accessors too { my $bar_accessor = $meta->find_method_by_name('bar'); isa_ok($bar_accessor, 'Class::MOP::Method::Accessor'); isa_ok($bar_accessor, 'Class::MOP::Method'); ok(!$bar_accessor->is_inline, '... the bar accessor is still not inlined'); my $baz_accessor = $meta->get_method('baz'); isa_ok($baz_accessor, 'Class::MOP::Method::Accessor'); isa_ok($baz_accessor, 'Class::MOP::Method'); ok($baz_accessor->is_inline, '... the baz accessor is not inlined'); } } { my $meta = Baz->meta; is($meta->name, 'Baz', '... checking the Bar metaclass'); { my $bar_accessor = $meta->find_method_by_name('bar'); isa_ok($bar_accessor, 'Class::MOP::Method::Accessor'); isa_ok($bar_accessor, 'Class::MOP::Method'); ok(!$bar_accessor->is_inline, '... the bar accessor is not inlined'); my $baz_accessor = $meta->find_method_by_name('baz'); isa_ok($baz_accessor, 'Class::MOP::Method::Accessor'); isa_ok($baz_accessor, 'Class::MOP::Method'); ok($baz_accessor->is_inline, '... the baz accessor is inlined'); my $bah_accessor = $meta->get_method('bah'); isa_ok($bah_accessor, 'Class::MOP::Method::Accessor'); isa_ok($bah_accessor, 'Class::MOP::Method'); ok(!$bah_accessor->is_inline, '... the baz accessor is not inlined'); } ok(!$meta->is_immutable, '... our class is not immutable'); is( exception { $meta->make_immutable( inline_constructor => 0, inline_accessors => 1, ); }, undef, '... changed Bar to be immutable' ); ok($meta->is_immutable, '... our class is now immutable'); isa_ok($meta, 'Class::MOP::Class'); ok(!Baz->meta->has_method('new'), '... no constructor was made'); { my $baz = Baz->meta->new_object; isa_ok($baz, 'Bar'); is($baz->bar, 'BAR', '... got the right default value'); is($baz->baz, 'BAZ', '... got the right default value'); } { my $baz = Baz->meta->new_object(bar => 'BAZ!', baz => 'BAR!', bah => 'BAH!'); isa_ok($baz, 'Baz'); is($baz->bar, 'BAZ!', '... got the right parameter value'); is($baz->baz, 'BAR!', '... got the right parameter value'); is($baz->bah, 'BAH!', '... got the right parameter value'); } # check out accessors too { my $bar_accessor = $meta->find_method_by_name('bar'); isa_ok($bar_accessor, 'Class::MOP::Method::Accessor'); isa_ok($bar_accessor, 'Class::MOP::Method'); ok(!$bar_accessor->is_inline, '... the bar accessor is still not inlined'); my $baz_accessor = $meta->find_method_by_name('baz'); isa_ok($baz_accessor, 'Class::MOP::Method::Accessor'); isa_ok($baz_accessor, 'Class::MOP::Method'); ok($baz_accessor->is_inline, '... the baz accessor is not inlined'); my $bah_accessor = $meta->get_method('bah'); isa_ok($bah_accessor, 'Class::MOP::Method::Accessor'); isa_ok($bah_accessor, 'Class::MOP::Method'); ok($bah_accessor->is_inline, '... the baz accessor is not inlined'); } } { my $buzz; ::is( ::exception { $buzz = Buzz->meta->new_object }, undef, '...Buzz instantiated successfully' ); ::ok(!$buzz->has_bar, '...bar is not set'); ::is($buzz->bar, undef, '...bar returns undef'); ::ok(!$buzz->has_bar, '...bar was not autovivified'); $buzz->bar(undef); ::ok($buzz->has_bar, '...bar is set'); ::is($buzz->bar, undef, '...bar is undef'); $buzz->clear_bar; ::ok(!$buzz->has_bar, '...bar is no longerset'); my $buzz2; ::is( ::exception { $buzz2 = Buzz->meta->new_object('bar' => undef) }, undef, '...Buzz instantiated successfully' ); ::ok($buzz2->has_bar, '...bar is set'); ::is($buzz2->bar, undef, '...bar is undef'); } { my $buzz; ::is( ::exception { $buzz = Buzz->meta->new_object }, undef, '...Buzz instantiated successfully' ); ::ok($buzz->has_bah, '...bah is set'); ::is($buzz->bah, 'BAH', '...bah returns "BAH"' ); my $buzz2; ::is( ::exception { $buzz2 = Buzz->meta->new_object('bah' => undef) }, undef, '...Buzz instantiated successfully' ); ::ok($buzz2->has_bah, '...bah is set'); ::is($buzz2->bah, undef, '...bah is undef'); } done_testing; immutable_roundtrip.t100644000767000024 135012200352345 21030 0ustar00etherstaff000000000000Moose-2.1005/t/immutable#!/usr/bin/perl use strict; use warnings; use Test::More; use Test::Requires { 'Test::Output' => '0.01', # skip all if not installed }; { package Foo; use Moose; __PACKAGE__->meta->make_immutable; } { package Bar; use Moose; extends 'Foo'; __PACKAGE__->meta->make_immutable; __PACKAGE__->meta->make_mutable; # This actually is testing for a bug in Class::MOP that cause # Moose::Meta::Method::Constructor to spit out a warning when it # shouldn't have done so. The bug was fixed in CMOP 0.75. ::stderr_unlike( sub { Bar->meta->make_immutable }, qr/Not inlining a constructor/, 'no warning that Bar may not have an inlined constructor' ); } done_testing; goto_moose_import.t100644000767000024 256112200352345 21041 0ustar00etherstaff000000000000Moose-2.1005/t/metaclasses#!/usr/bin/perl use strict; use warnings; use Test::More; use Test::Fatal; # Some packages out in the wild cooperate with Moose by using goto # &Moose::import. we want to make sure it still works. { package MooseAlike1; use strict; use warnings; use Moose (); sub import { goto &Moose::import; } sub unimport { goto &Moose::unimport; } } { package Foo; MooseAlike1->import(); ::is( ::exception { has( 'size', is => 'bare' ) }, undef, 'has was exported via MooseAlike1' ); MooseAlike1->unimport(); } ok( ! Foo->can('has'), 'No has sub in Foo after MooseAlike1 is unimported' ); ok( Foo->can('meta'), 'Foo has a meta method' ); isa_ok( Foo->meta(), 'Moose::Meta::Class' ); { package MooseAlike2; use strict; use warnings; use Moose (); my $import = \&Moose::import; sub import { goto $import; } my $unimport = \&Moose::unimport; sub unimport { goto $unimport; } } { package Bar; MooseAlike2->import(); ::is( ::exception { has( 'size', is => 'bare' ) }, undef, 'has was exported via MooseAlike2' ); MooseAlike2->unimport(); } ok( ! Bar->can('has'), 'No has sub in Bar after MooseAlike2 is unimported' ); ok( Bar->can('meta'), 'Bar has a meta method' ); isa_ok( Bar->meta(), 'Moose::Meta::Class' ); done_testing; moose_w_metaclass.t100644000767000024 167012200352345 21001 0ustar00etherstaff000000000000Moose-2.1005/t/metaclasses#!/usr/bin/perl use strict; use warnings; use Test::More; =pod This test demonstrates that Moose will respect a metaclass previously set with the metaclass pragma. It also checks an error condition where that metaclass must be a Moose::Meta::Class subclass in order to work. =cut { package Foo::Meta; use strict; use warnings; use base 'Moose::Meta::Class'; package Foo; use strict; use warnings; use metaclass 'Foo::Meta'; ::use_ok('Moose'); } isa_ok(Foo->meta, 'Foo::Meta'); { package Bar::Meta; use strict; use warnings; use base 'Class::MOP::Class'; package Bar; use strict; use warnings; use metaclass 'Bar::Meta'; eval 'use Moose;'; ::ok($@, '... could not load moose without correct metaclass'); ::like($@, qr/^Bar already has a metaclass, but it does not inherit Moose::Meta::Class/, '... got the right error too'); } done_testing; use_base_of_moose.t100644000767000024 110212200352345 20737 0ustar00etherstaff000000000000Moose-2.1005/t/metaclasses#!/usr/bin/env perl use strict; use warnings; use Test::More; { package NoOpTrait; use Moose::Role; } { package Parent; use Moose -traits => 'NoOpTrait'; has attr => ( is => 'rw', isa => 'Str', ); } { package Child; use base 'Parent'; } is(Child->meta->name, 'Child', "correct metaclass name"); my $child = Child->new(attr => "ibute"); ok($child, "constructor works"); is($child->attr, "ibute", "getter inherited properly"); $child->attr("ition"); is($child->attr, "ition", "setter inherited properly"); done_testing; array_from_role.t100644000767000024 143112200352345 21022 0ustar00etherstaff000000000000Moose-2.1005/t/native_traits#!/usr/bin/perl use strict; use warnings; use Test::More; use Test::Fatal; { package Foo; use Moose; has 'bar' => ( is => 'rw' ); package Stuffed::Role; use Moose::Role; has 'options' => ( traits => ['Array'], is => 'ro', isa => 'ArrayRef[Foo]', ); package Bulkie::Role; use Moose::Role; has 'stuff' => ( traits => ['Array'], is => 'ro', isa => 'ArrayRef', handles => { get_stuff => 'get', } ); package Stuff; use Moose; ::is( ::exception { with 'Stuffed::Role'; }, undef, '... this should work correctly' ); ::is( ::exception { with 'Bulkie::Role'; }, undef, '... this should work correctly' ); } done_testing; custom_instance.t100644000767000024 2122712200352345 21063 0ustar00etherstaff000000000000Moose-2.1005/t/native_traits#!/usr/bin/env perl use strict; use warnings; use Test::More; use Test::Fatal; use Test::Moose; { package ValueContainer; use Moose; has value => ( is => 'rw', ); } { package Foo::Meta::Instance; use Moose::Role; around get_slot_value => sub { my $orig = shift; my $self = shift; my ($instance, $slot_name) = @_; my $value = $self->$orig(@_); if ($value->isa('ValueContainer')) { $value = $value->value; } return $value; }; around inline_get_slot_value => sub { my $orig = shift; my $self = shift; my $value = $self->$orig(@_); return q[do {] . "\n" . q[ my $value = ] . $value . q[;] . "\n" . q[ if ($value->isa('ValueContainer')) {] . "\n" . q[ $value = $value->value;] . "\n" . q[ }] . "\n" . q[ $value] . "\n" . q[}]; }; sub inline_get_is_lvalue { 0 } } { package Foo; use Moose; Moose::Util::MetaRole::apply_metaroles( for => __PACKAGE__, class_metaroles => { instance => ['Foo::Meta::Instance'], } ); ::is( ::exception { has array => ( traits => ['Array'], isa => 'ArrayRef', default => sub { [] }, handles => { array_count => 'count', array_elements => 'elements', array_is_empty => 'is_empty', array_push => 'push', array_push_curried => [ push => 42, 84 ], array_unshift => 'unshift', array_unshift_curried => [ unshift => 42, 84 ], array_pop => 'pop', array_shift => 'shift', array_get => 'get', array_get_curried => [ get => 1 ], array_set => 'set', array_set_curried_1 => [ set => 1 ], array_set_curried_2 => [ set => ( 1, 98 ) ], array_accessor => 'accessor', array_accessor_curried_1 => [ accessor => 1 ], array_accessor_curried_2 => [ accessor => ( 1, 90 ) ], array_clear => 'clear', array_delete => 'delete', array_delete_curried => [ delete => 1 ], array_insert => 'insert', array_insert_curried => [ insert => ( 1, 101 ) ], array_splice => 'splice', array_splice_curried_1 => [ splice => 1 ], array_splice_curried_2 => [ splice => 1, 2 ], array_splice_curried_all => [ splice => 1, 2, ( 3, 4, 5 ) ], array_sort => 'sort', array_sort_curried => [ sort => ( sub { $_[1] <=> $_[0] } ) ], array_sort_in_place => 'sort_in_place', array_sort_in_place_curried => [ sort_in_place => ( sub { $_[1] <=> $_[0] } ) ], array_map => 'map', array_map_curried => [ map => ( sub { $_ + 1 } ) ], array_grep => 'grep', array_grep_curried => [ grep => ( sub { $_ < 5 } ) ], array_first => 'first', array_first_curried => [ first => ( sub { $_ % 2 } ) ], array_join => 'join', array_join_curried => [ join => '-' ], array_shuffle => 'shuffle', array_uniq => 'uniq', array_reduce => 'reduce', array_reduce_curried => [ reduce => ( sub { $_[0] * $_[1] } ) ], array_natatime => 'natatime', array_natatime_curried => [ natatime => 2 ], }, ); }, undef, "native array trait inlines properly" ); ::is( ::exception { has bool => ( traits => ['Bool'], isa => 'Bool', default => 0, handles => { bool_illuminate => 'set', bool_darken => 'unset', bool_flip_switch => 'toggle', bool_is_dark => 'not', }, ); }, undef, "native bool trait inlines properly" ); ::is( ::exception { has code => ( traits => ['Code'], isa => 'CodeRef', default => sub { sub { } }, handles => { code_execute => 'execute', code_execute_method => 'execute_method', }, ); }, undef, "native code trait inlines properly" ); ::is( ::exception { has counter => ( traits => ['Counter'], isa => 'Int', default => 0, handles => { inc_counter => 'inc', inc_counter_2 => [ inc => 2 ], dec_counter => 'dec', dec_counter_2 => [ dec => 2 ], reset_counter => 'reset', set_counter => 'set', set_counter_42 => [ set => 42 ], }, ); }, undef, "native counter trait inlines properly" ); ::is( ::exception { has hash => ( traits => ['Hash'], isa => 'HashRef', default => sub { {} }, handles => { hash_option_accessor => 'accessor', hash_quantity => [ accessor => 'quantity' ], hash_clear_options => 'clear', hash_num_options => 'count', hash_delete_option => 'delete', hash_is_defined => 'defined', hash_options_elements => 'elements', hash_has_option => 'exists', hash_get_option => 'get', hash_has_no_options => 'is_empty', hash_key_value => 'kv', hash_set_option => 'set', }, ); }, undef, "native hash trait inlines properly" ); ::is( ::exception { has number => ( traits => ['Number'], isa => 'Num', default => 0, handles => { num_abs => 'abs', num_add => 'add', num_inc => [ add => 1 ], num_div => 'div', num_cut_in_half => [ div => 2 ], num_mod => 'mod', num_odd => [ mod => 2 ], num_mul => 'mul', num_set => 'set', num_sub => 'sub', num_dec => [ sub => 1 ], }, ); }, undef, "native number trait inlines properly" ); ::is( ::exception { has string => ( traits => ['String'], is => 'ro', isa => 'Str', default => '', handles => { string_inc => 'inc', string_append => 'append', string_append_curried => [ append => '!' ], string_prepend => 'prepend', string_prepend_curried => [ prepend => '-' ], string_replace => 'replace', string_replace_curried => [ replace => qr/(.)$/, sub { uc $1 } ], string_chop => 'chop', string_chomp => 'chomp', string_clear => 'clear', string_match => 'match', string_match_curried => [ match => qr/\D/ ], string_length => 'length', string_substr => 'substr', string_substr_curried_1 => [ substr => (1) ], string_substr_curried_2 => [ substr => ( 1, 3 ) ], string_substr_curried_3 => [ substr => ( 1, 3, 'ong' ) ], }, ); }, undef, "native string trait inlines properly" ); } with_immutable { { my $foo = Foo->new(string => 'a'); is($foo->string, 'a'); $foo->string_append('b'); is($foo->string, 'ab'); } { my $foo = Foo->new(string => ''); $foo->{string} = ValueContainer->new(value => 'a'); is($foo->string, 'a'); $foo->string_append('b'); is($foo->string, 'ab'); } } 'Foo'; done_testing; role_attribute_conflict.t100644000767000024 63412200352345 21001 0ustar00etherstaff000000000000Moose-2.1005/t/rolesuse strict; use warnings; use Test::More; use Test::Fatal; { package My::Role1; use Moose::Role; has foo => ( is => 'ro', ); } { package My::Role2; use Moose::Role; has foo => ( is => 'ro', ); ::like( ::exception { with 'My::Role1' }, qr/attribute conflict.+My::Role2.+foo/, 'attribute conflict when composing one role into another' ); } done_testing; role_composition_errors.t100644000767000024 653412200352345 21101 0ustar00etherstaff000000000000Moose-2.1005/t/roles#!/usr/bin/perl use strict; use warnings; use Test::More; use Test::Fatal; { package Foo::Role; use Moose::Role; requires 'foo'; } is_deeply( [ sort Foo::Role->meta->get_required_method_list ], ['foo'], '... the Foo::Role has a required method (foo)' ); # classes which does not implement required method { package Foo::Class; use Moose; ::isnt( ::exception { with('Foo::Role') }, undef, '... no foo method implemented by Foo::Class' ); } # class which does implement required method { package Bar::Class; use Moose; ::isnt( ::exception { with('Foo::Class') }, undef, '... cannot consume a class, it must be a role' ); ::is( ::exception { with('Foo::Role') }, undef, '... has a foo method implemented by Bar::Class' ); sub foo {'Bar::Class::foo'} } # role which does implement required method { package Bar::Role; use Moose::Role; ::is( ::exception { with('Foo::Role') }, undef, '... has a foo method implemented by Bar::Role' ); sub foo {'Bar::Role::foo'} } is_deeply( [ sort Bar::Role->meta->get_required_method_list ], [], '... the Bar::Role has not inherited the required method from Foo::Role' ); # role which does not implement required method { package Baz::Role; use Moose::Role; ::is( ::exception { with('Foo::Role') }, undef, '... no foo method implemented by Baz::Role' ); } is_deeply( [ sort Baz::Role->meta->get_required_method_list ], ['foo'], '... the Baz::Role has inherited the required method from Foo::Role' ); # classes which does not implement required method { package Baz::Class; use Moose; ::isnt( ::exception { with('Baz::Role') }, undef, '... no foo method implemented by Baz::Class2' ); } # class which does implement required method { package Baz::Class2; use Moose; ::is( ::exception { with('Baz::Role') }, undef, '... has a foo method implemented by Baz::Class2' ); sub foo {'Baz::Class2::foo'} } { package Quux::Role; use Moose::Role; requires qw( meth1 meth2 meth3 meth4 ); } # RT #41119 { package Quux::Class; use Moose; ::like( ::exception { with('Quux::Role') }, qr/\Q'Quux::Role' requires the methods 'meth1', 'meth2', 'meth3', and 'meth4' to be implemented by 'Quux::Class'/, 'exception mentions all the missing required methods at once' ); } { package Quux::Class2; use Moose; sub meth1 { } ::like( ::exception { with('Quux::Role') }, qr/'Quux::Role' requires the methods 'meth2', 'meth3', and 'meth4' to be implemented by 'Quux::Class2'/, 'exception mentions all the missing required methods at once, but not the one that exists' ); } { package Quux::Class3; use Moose; has 'meth1' => ( is => 'ro' ); has 'meth2' => ( is => 'ro' ); ::like( ::exception { with('Quux::Role') }, qr/'Quux::Role' requires the methods 'meth3' and 'meth4' to be implemented by 'Quux::Class3'/, 'exception mentions all the missing methods at once, but not the accessors' ); } { package Quux::Class4; use Moose; sub meth1 { } has 'meth2' => ( is => 'ro' ); ::like( ::exception { with('Quux::Role') }, qr/'Quux::Role' requires the methods 'meth3' and 'meth4' to be implemented by 'Quux::Class4'/, 'exception mentions all the require methods that are accessors at once, as well as missing methods, but not the one that exists' ); } done_testing; role_conflict_detection.t100644000767000024 4521712200352345 21022 0ustar00etherstaff000000000000Moose-2.1005/t/roles#!/usr/bin/perl use strict; use warnings; use Test::More; use Test::Fatal; =pod Mutually recursive roles. =cut { package Role::Foo; use Moose::Role; requires 'foo'; sub bar { 'Role::Foo::bar' } package Role::Bar; use Moose::Role; requires 'bar'; sub foo { 'Role::Bar::foo' } } { package My::Test1; use Moose; ::is( ::exception { with 'Role::Foo', 'Role::Bar'; }, undef, '... our mutually recursive roles combine okay' ); package My::Test2; use Moose; ::is( ::exception { with 'Role::Bar', 'Role::Foo'; }, undef, '... our mutually recursive roles combine okay (no matter what order)' ); } my $test1 = My::Test1->new; isa_ok($test1, 'My::Test1'); ok($test1->does('Role::Foo'), '... $test1 does Role::Foo'); ok($test1->does('Role::Bar'), '... $test1 does Role::Bar'); can_ok($test1, 'foo'); can_ok($test1, 'bar'); is($test1->foo, 'Role::Bar::foo', '... $test1->foo worked'); is($test1->bar, 'Role::Foo::bar', '... $test1->bar worked'); my $test2 = My::Test2->new; isa_ok($test2, 'My::Test2'); ok($test2->does('Role::Foo'), '... $test2 does Role::Foo'); ok($test2->does('Role::Bar'), '... $test2 does Role::Bar'); can_ok($test2, 'foo'); can_ok($test2, 'bar'); is($test2->foo, 'Role::Bar::foo', '... $test2->foo worked'); is($test2->bar, 'Role::Foo::bar', '... $test2->bar worked'); # check some meta-stuff ok(Role::Foo->meta->has_method('bar'), '... it still has the bar method'); ok(Role::Foo->meta->requires_method('foo'), '... it still has the required foo method'); ok(Role::Bar->meta->has_method('foo'), '... it still has the foo method'); ok(Role::Bar->meta->requires_method('bar'), '... it still has the required bar method'); =pod Role method conflicts =cut { package Role::Bling; use Moose::Role; sub bling { 'Role::Bling::bling' } package Role::Bling::Bling; use Moose::Role; sub bling { 'Role::Bling::Bling::bling' } } { package My::Test3; use Moose; ::like( ::exception { with 'Role::Bling', 'Role::Bling::Bling'; }, qr/Due to a method name conflict in roles 'Role::Bling' and 'Role::Bling::Bling', the method 'bling' must be implemented or excluded by 'My::Test3'/, '... role methods conflict and method was required' ); package My::Test4; use Moose; ::is( ::exception { with 'Role::Bling'; with 'Role::Bling::Bling'; }, undef, '... role methods didnt conflict when manually combined' ); package My::Test5; use Moose; ::is( ::exception { with 'Role::Bling::Bling'; with 'Role::Bling'; }, undef, '... role methods didnt conflict when manually combined (in opposite order)' ); package My::Test6; use Moose; ::is( ::exception { with 'Role::Bling::Bling', 'Role::Bling'; }, undef, '... role methods didnt conflict when manually resolved' ); sub bling { 'My::Test6::bling' } package My::Test7; use Moose; ::is( ::exception { with 'Role::Bling::Bling', { -excludes => ['bling'] }, 'Role::Bling'; }, undef, '... role methods didnt conflict when one of the conflicting methods is excluded' ); package My::Test8; use Moose; ::is( ::exception { with 'Role::Bling::Bling', { -excludes => ['bling'], -alias => { bling => 'bling_bling' } }, 'Role::Bling'; }, undef, '... role methods didnt conflict when one of the conflicting methods is excluded and aliased' ); } ok(!My::Test3->meta->has_method('bling'), '... we didnt get any methods in the conflict'); ok(My::Test4->meta->has_method('bling'), '... we did get the method when manually dealt with'); ok(My::Test5->meta->has_method('bling'), '... we did get the method when manually dealt with'); ok(My::Test6->meta->has_method('bling'), '... we did get the method when manually dealt with'); ok(My::Test7->meta->has_method('bling'), '... we did get the method when manually dealt with'); ok(My::Test8->meta->has_method('bling'), '... we did get the method when manually dealt with'); ok(My::Test8->meta->has_method('bling_bling'), '... we did get the aliased method too'); ok(!My::Test3->does('Role::Bling'), '... our class does() the correct roles'); ok(!My::Test3->does('Role::Bling::Bling'), '... our class does() the correct roles'); ok(My::Test4->does('Role::Bling'), '... our class does() the correct roles'); ok(My::Test4->does('Role::Bling::Bling'), '... our class does() the correct roles'); ok(My::Test5->does('Role::Bling'), '... our class does() the correct roles'); ok(My::Test5->does('Role::Bling::Bling'), '... our class does() the correct roles'); ok(My::Test6->does('Role::Bling'), '... our class does() the correct roles'); ok(My::Test6->does('Role::Bling::Bling'), '... our class does() the correct roles'); ok(My::Test7->does('Role::Bling'), '... our class does() the correct roles'); ok(My::Test7->does('Role::Bling::Bling'), '... our class does() the correct roles'); ok(My::Test8->does('Role::Bling'), '... our class does() the correct roles'); ok(My::Test8->does('Role::Bling::Bling'), '... our class does() the correct roles'); is(My::Test4->bling, 'Role::Bling::bling', '... and we got the first method that was added'); is(My::Test5->bling, 'Role::Bling::Bling::bling', '... and we got the first method that was added'); is(My::Test6->bling, 'My::Test6::bling', '... and we got the local method'); is(My::Test7->bling, 'Role::Bling::bling', '... and we got the non-excluded method'); is(My::Test8->bling, 'Role::Bling::bling', '... and we got the non-excluded/aliased method'); is(My::Test8->bling_bling, 'Role::Bling::Bling::bling', '... and the aliased method comes from the correct role'); # check how this affects role compostion { package Role::Bling::Bling::Bling; use Moose::Role; with 'Role::Bling::Bling'; sub bling { 'Role::Bling::Bling::Bling::bling' } } ok(Role::Bling::Bling->meta->has_method('bling'), '... still got the bling method in Role::Bling::Bling'); ok(Role::Bling::Bling->meta->does_role('Role::Bling::Bling'), '... our role correctly does() the other role'); ok(Role::Bling::Bling::Bling->meta->has_method('bling'), '... dont have the bling method in Role::Bling::Bling::Bling'); is(Role::Bling::Bling::Bling->meta->get_method('bling')->(), 'Role::Bling::Bling::Bling::bling', '... still got the bling method in Role::Bling::Bling::Bling'); =pod Role attribute conflicts =cut { package Role::Boo; use Moose::Role; has 'ghost' => (is => 'ro', default => 'Role::Boo::ghost'); package Role::Boo::Hoo; use Moose::Role; has 'ghost' => (is => 'ro', default => 'Role::Boo::Hoo::ghost'); } { package My::Test7; use Moose; ::like( ::exception { with 'Role::Boo', 'Role::Boo::Hoo'; }, qr/We have encountered an attribute conflict.+ghost/ ); package My::Test8; use Moose; ::is( ::exception { with 'Role::Boo'; with 'Role::Boo::Hoo'; }, undef, '... role attrs didnt conflict when manually combined' ); package My::Test9; use Moose; ::is( ::exception { with 'Role::Boo::Hoo'; with 'Role::Boo'; }, undef, '... role attrs didnt conflict when manually combined' ); package My::Test10; use Moose; has 'ghost' => (is => 'ro', default => 'My::Test10::ghost'); ::like( ::exception { with 'Role::Boo', 'Role::Boo::Hoo'; }, qr/We have encountered an attribute conflict/, '... role attrs conflict and cannot be manually disambiguted' ); } ok(!My::Test7->meta->has_attribute('ghost'), '... we didnt get any attributes in the conflict'); ok(My::Test8->meta->has_attribute('ghost'), '... we did get an attributes when manually composed'); ok(My::Test9->meta->has_attribute('ghost'), '... we did get an attributes when manually composed'); ok(My::Test10->meta->has_attribute('ghost'), '... we did still have an attribute ghost (conflict does not mess with class)'); ok(!My::Test7->does('Role::Boo'), '... our class does() the correct roles'); ok(!My::Test7->does('Role::Boo::Hoo'), '... our class does() the correct roles'); ok(My::Test8->does('Role::Boo'), '... our class does() the correct roles'); ok(My::Test8->does('Role::Boo::Hoo'), '... our class does() the correct roles'); ok(My::Test9->does('Role::Boo'), '... our class does() the correct roles'); ok(My::Test9->does('Role::Boo::Hoo'), '... our class does() the correct roles'); ok(!My::Test10->does('Role::Boo'), '... our class does() the correct roles'); ok(!My::Test10->does('Role::Boo::Hoo'), '... our class does() the correct roles'); can_ok('My::Test8', 'ghost'); can_ok('My::Test9', 'ghost'); can_ok('My::Test10', 'ghost'); is(My::Test8->new->ghost, 'Role::Boo::ghost', '... got the expected default attr value'); is(My::Test9->new->ghost, 'Role::Boo::Hoo::ghost', '... got the expected default attr value'); is(My::Test10->new->ghost, 'My::Test10::ghost', '... got the expected default attr value'); =pod Role override method conflicts =cut { package Role::Plot; use Moose::Role; override 'twist' => sub { super() . ' -> Role::Plot::twist'; }; package Role::Truth; use Moose::Role; override 'twist' => sub { super() . ' -> Role::Truth::twist'; }; } { package My::Test::Base; use Moose; sub twist { 'My::Test::Base::twist' } package My::Test11; use Moose; extends 'My::Test::Base'; ::is( ::exception { with 'Role::Truth'; }, undef, '... composed the role with override okay' ); package My::Test12; use Moose; extends 'My::Test::Base'; ::is( ::exception { with 'Role::Plot'; }, undef, '... composed the role with override okay' ); package My::Test13; use Moose; ::isnt( ::exception { with 'Role::Plot'; }, undef, '... cannot compose it because we have no superclass' ); package My::Test14; use Moose; extends 'My::Test::Base'; ::like( ::exception { with 'Role::Plot', 'Role::Truth'; }, qr/Two \'override\' methods of the same name encountered/, '... cannot compose it because we have no superclass' ); } ok(My::Test11->meta->has_method('twist'), '... the twist method has been added'); ok(My::Test12->meta->has_method('twist'), '... the twist method has been added'); ok(!My::Test13->meta->has_method('twist'), '... the twist method has not been added'); ok(!My::Test14->meta->has_method('twist'), '... the twist method has not been added'); ok(!My::Test11->does('Role::Plot'), '... our class does() the correct roles'); ok(My::Test11->does('Role::Truth'), '... our class does() the correct roles'); ok(!My::Test12->does('Role::Truth'), '... our class does() the correct roles'); ok(My::Test12->does('Role::Plot'), '... our class does() the correct roles'); ok(!My::Test13->does('Role::Plot'), '... our class does() the correct roles'); ok(!My::Test14->does('Role::Truth'), '... our class does() the correct roles'); ok(!My::Test14->does('Role::Plot'), '... our class does() the correct roles'); is(My::Test11->twist(), 'My::Test::Base::twist -> Role::Truth::twist', '... got the right method return'); is(My::Test12->twist(), 'My::Test::Base::twist -> Role::Plot::twist', '... got the right method return'); ok(!My::Test13->can('twist'), '... no twist method here at all'); is(My::Test14->twist(), 'My::Test::Base::twist', '... got the right method return (from superclass)'); { package Role::Reality; use Moose::Role; ::like( ::exception { with 'Role::Plot'; }, qr/A local method of the same name as been found/, '... could not compose roles here, it dies' ); sub twist { 'Role::Reality::twist'; } } ok(Role::Reality->meta->has_method('twist'), '... the twist method has not been added'); #ok(!Role::Reality->meta->does_role('Role::Plot'), '... our role does() the correct roles'); is(Role::Reality->meta->get_method('twist')->(), 'Role::Reality::twist', '... the twist method returns the right value'); # Ovid's test case from rt.cpan.org #44 { package Role1; use Moose::Role; sub foo {} } { package Role2; use Moose::Role; sub foo {} } { package Conflicts; use Moose; ::like( ::exception { with qw(Role1 Role2); }, qr/Due to a method name conflict in roles 'Role1' and 'Role2', the method 'foo' must be implemented or excluded by 'Conflicts'/ ); } =pod Role conflicts between attributes and methods [15:23] when class defines method and role defines method, class wins [15:24] when class 'has' method and role defines method, class wins [15:24] when class defines method and role 'has' method, role wins [15:24] when class 'has' method and role 'has' method, role wins [15:24] which means when class 'has' method and two roles 'has' method, no tiebreak is detected [15:24] this is with role and has declaration in the exact same order in every case? [15:25] yes [15:25] interesting [15:25] that's what I thought [15:26] does that sound like something I should write a test for? [15:27] stevan, ping? [15:27] I'm not sure what the right answer for composition is. [15:27] who should win [15:27] if I were to guess I'd say the class should always win. [15:27] that would be my guess, but I thought I would ask to make sure [15:29] kolibrie: please write a test [15:29] I am not exactly sure who should win either,.. but I suspect it is not working correctly right now [15:29] I know exactly why it is doing what it is doing though Now I have to decide actually what happens, and how to fix it. - SL { package Role::Method; use Moose::Role; sub ghost { 'Role::Method::ghost' } package Role::Method2; use Moose::Role; sub ghost { 'Role::Method2::ghost' } package Role::Attribute; use Moose::Role; has 'ghost' => (is => 'ro', default => 'Role::Attribute::ghost'); package Role::Attribute2; use Moose::Role; has 'ghost' => (is => 'ro', default => 'Role::Attribute2::ghost'); } { package My::Test15; use Moose; ::lives_ok { with 'Role::Method'; } '... composed the method role into the method class'; sub ghost { 'My::Test15::ghost' } package My::Test16; use Moose; ::lives_ok { with 'Role::Method'; } '... composed the method role into the attribute class'; has 'ghost' => (is => 'ro', default => 'My::Test16::ghost'); package My::Test17; use Moose; ::lives_ok { with 'Role::Attribute'; } '... composed the attribute role into the method class'; sub ghost { 'My::Test17::ghost' } package My::Test18; use Moose; ::lives_ok { with 'Role::Attribute'; } '... composed the attribute role into the attribute class'; has 'ghost' => (is => 'ro', default => 'My::Test18::ghost'); package My::Test19; use Moose; ::lives_ok { with 'Role::Method', 'Role::Method2'; } '... composed method roles into class with method tiebreaker'; sub ghost { 'My::Test19::ghost' } package My::Test20; use Moose; ::lives_ok { with 'Role::Method', 'Role::Method2'; } '... composed method roles into class with attribute tiebreaker'; has 'ghost' => (is => 'ro', default => 'My::Test20::ghost'); package My::Test21; use Moose; ::lives_ok { with 'Role::Attribute', 'Role::Attribute2'; } '... composed attribute roles into class with method tiebreaker'; sub ghost { 'My::Test21::ghost' } package My::Test22; use Moose; ::lives_ok { with 'Role::Attribute', 'Role::Attribute2'; } '... composed attribute roles into class with attribute tiebreaker'; has 'ghost' => (is => 'ro', default => 'My::Test22::ghost'); package My::Test23; use Moose; ::lives_ok { with 'Role::Method', 'Role::Attribute'; } '... composed method and attribute role into class with method tiebreaker'; sub ghost { 'My::Test23::ghost' } package My::Test24; use Moose; ::lives_ok { with 'Role::Method', 'Role::Attribute'; } '... composed method and attribute role into class with attribute tiebreaker'; has 'ghost' => (is => 'ro', default => 'My::Test24::ghost'); package My::Test25; use Moose; ::lives_ok { with 'Role::Attribute', 'Role::Method'; } '... composed attribute and method role into class with method tiebreaker'; sub ghost { 'My::Test25::ghost' } package My::Test26; use Moose; ::lives_ok { with 'Role::Attribute', 'Role::Method'; } '... composed attribute and method role into class with attribute tiebreaker'; has 'ghost' => (is => 'ro', default => 'My::Test26::ghost'); } my $test15 = My::Test15->new; isa_ok($test15, 'My::Test15'); is($test15->ghost, 'My::Test15::ghost', '... we access the method from the class and ignore the role method'); my $test16 = My::Test16->new; isa_ok($test16, 'My::Test16'); is($test16->ghost, 'My::Test16::ghost', '... we access the attribute from the class and ignore the role method'); my $test17 = My::Test17->new; isa_ok($test17, 'My::Test17'); is($test17->ghost, 'My::Test17::ghost', '... we access the method from the class and ignore the role attribute'); my $test18 = My::Test18->new; isa_ok($test18, 'My::Test18'); is($test18->ghost, 'My::Test18::ghost', '... we access the attribute from the class and ignore the role attribute'); my $test19 = My::Test19->new; isa_ok($test19, 'My::Test19'); is($test19->ghost, 'My::Test19::ghost', '... we access the method from the class and ignore the role methods'); my $test20 = My::Test20->new; isa_ok($test20, 'My::Test20'); is($test20->ghost, 'My::Test20::ghost', '... we access the attribute from the class and ignore the role methods'); my $test21 = My::Test21->new; isa_ok($test21, 'My::Test21'); is($test21->ghost, 'My::Test21::ghost', '... we access the method from the class and ignore the role attributes'); my $test22 = My::Test22->new; isa_ok($test22, 'My::Test22'); is($test22->ghost, 'My::Test22::ghost', '... we access the attribute from the class and ignore the role attributes'); my $test23 = My::Test23->new; isa_ok($test23, 'My::Test23'); is($test23->ghost, 'My::Test23::ghost', '... we access the method from the class and ignore the role method and attribute'); my $test24 = My::Test24->new; isa_ok($test24, 'My::Test24'); is($test24->ghost, 'My::Test24::ghost', '... we access the attribute from the class and ignore the role method and attribute'); my $test25 = My::Test25->new; isa_ok($test25, 'My::Test25'); is($test25->ghost, 'My::Test25::ghost', '... we access the method from the class and ignore the role attribute and method'); my $test26 = My::Test26->new; isa_ok($test26, 'My::Test26'); is($test26->ghost, 'My::Test26::ghost', '... we access the attribute from the class and ignore the role attribute and method'); =cut done_testing; roles_applied_in_create.t100644000767000024 105612200352345 20746 0ustar00etherstaff000000000000Moose-2.1005/t/roles#!/usr/bin/perl use strict; use warnings; use Test::More; use Test::Fatal; use Moose::Meta::Class; use Moose::Util; use lib 't/lib', 'lib'; # Note that this test passed (pre svn #5543) if we inlined the role # definitions in this file, as it was very timing sensitive. is( exception { my $builder_meta = Moose::Meta::Class->create( 'YATTA' => ( superclass => 'Moose::Meta::Class', roles => [qw( Role::Interface Role::Child )], ) ); }, undef, 'Create a new class with several roles' ); done_testing; runtime_roles_and_attrs.t100644000767000024 212712200352345 21041 0ustar00etherstaff000000000000Moose-2.1005/t/roles#!/usr/bin/perl use strict; use warnings; use Test::More; use Test::Fatal; use Scalar::Util 'blessed'; { package Dog; use Moose::Role; sub talk { 'woof' } has fur => ( isa => "Str", is => "rw", default => "dirty", ); package Foo; use Moose; has 'dog' => ( is => 'rw', does => 'Dog', ); } my $obj = Foo->new; isa_ok($obj, 'Foo'); ok(!$obj->can( 'talk' ), "... the role is not composed yet"); ok(!$obj->can( 'fur' ), 'ditto'); ok(!$obj->does('Dog'), '... we do not do any roles yet'); isnt( exception { $obj->dog($obj) }, undef, '... and setting the accessor fails (not a Dog yet)' ); Dog->meta->apply($obj); ok($obj->does('Dog'), '... we now do the Bark role'); ok($obj->can('talk'), "... the role is now composed at the object level"); ok($obj->can('fur'), "it has fur"); is($obj->talk, 'woof', '... got the right return value for the newly composed method'); is( exception { $obj->dog($obj) }, undef, '... and setting the accessor is okay' ); is($obj->fur, "dirty", "role attr initialized"); done_testing; test_moose_does_ok.t100644000767000024 134312200352345 21033 0ustar00etherstaff000000000000Moose-2.1005/t/test_moose#!/usr/bin/perl use strict; use warnings; use Test::Builder::Tester; use Test::More; use Test::Moose; { package Foo; use Moose::Role; } { package Bar; use Moose; with qw/Foo/; } { package Baz; use Moose; } # class ok test_out('ok 1 - does_ok class'); does_ok('Bar','Foo','does_ok class'); # class fail test_out ('not ok 2 - does_ok class fail'); test_fail (+2); does_ok('Baz','Foo','does_ok class fail'); # object ok my $bar = Bar->new; test_out ('ok 3 - does_ok object'); does_ok ($bar,'Foo','does_ok object'); # object fail my $baz = Baz->new; test_out ('not ok 4 - does_ok object fail'); test_fail (+2); does_ok ($baz,'Foo','does_ok object fail'); test_test ('does_ok'); done_testing; test_moose_meta_ok.t100644000767000024 62012200352345 21004 0ustar00etherstaff000000000000Moose-2.1005/t/test_moose#!/usr/bin/perl use strict; use warnings; use Test::Builder::Tester; use Test::More; use Test::Moose; { package Foo; use Moose; } { package Bar; } test_out('ok 1 - ... meta_ok(Foo) passes'); meta_ok('Foo', '... meta_ok(Foo) passes'); test_out ('not ok 2 - ... meta_ok(Bar) fails'); test_fail (+2); meta_ok('Bar', '... meta_ok(Bar) fails'); test_test ('meta_ok'); done_testing; with_immutable_tb2.t100644000767000024 332312200352345 20730 0ustar00etherstaff000000000000Moose-2.1005/t/test_mooseuse strict; use warnings; use Test::More; BEGIN { use Test::More; plan skip_all => 'These tests are only for Test::Builder 1.005+' if Test::Builder->VERSION < 1.005; } { package Foo; use Moose; } { package Bar; use Moose; } package main; use Test::Moose; use TB2::Tester; use TB2::History; # FIXME - this should not need to be loaded here explicitly my ($ret1, $ret2); my $capture = capture { $ret1 = with_immutable { ok(Foo->meta->is_mutable, 'is mutable'); } qw(Foo); $ret2 = with_immutable { ok(Bar->meta->find_method_by_name('new'), 'can find "new" method'); } qw(Bar); }; my $results = $capture->results; my @tests = ( [ 'first test runs while Foo is mutable' => { name => 'is mutable', is_pass => 1, }, ], [ 'first test runs while Foo is immutable' => { name => 'is mutable', is_pass => 0, }, ], [ 'can find "new" while Bar is mutable' => { name => 'can find "new" method', is_pass => 1, }, ], [ 'can find "new" while Bar is immutable' => { name => 'can find "new" method', is_pass => 1, }, ], ); result_like(shift(@$results), $_->[1], $_->[0]) foreach @tests; ok(!$ret1, 'one of the is_immutable tests failed'); ok($ret2, 'the find_method_by_name tests passed'); done_testing; immutable_n_around.t100644000767000024 225412200352345 21023 0ustar00etherstaff000000000000Moose-2.1005/t/todo_tests#!/usr/bin/perl use strict; use warnings; use Test::More; # if make_immutable is removed from the following code the tests pass { package Foo; use Moose; has foo => ( is => "ro" ); package Bar; use Moose; extends qw(Foo); around new => sub { my $next = shift; my ( $self, @args ) = @_; $self->$next( foo => 42 ); }; package Gorch; use Moose; extends qw(Bar); package Zoink; use Moose; extends qw(Gorch); } my @classes = qw(Foo Bar Gorch Zoink); tests: { is( Foo->new->foo, undef, "base class (" . (Foo->meta->is_immutable ? "immutable" : "mutable") . ")" ); is( Bar->new->foo, 42, "around new called on Bar->new (" . (Bar->meta->is_immutable ? "immutable" : "mutable") . ")" ); is( Gorch->new->foo, 42, "around new called on Gorch->new (" . (Gorch->meta->is_immutable ? "immutable" : "mutable") . ")" ); is( Zoink->new->foo, 42, "around new called Zoink->new (" . (Zoink->meta->is_immutable ? "immutable" : "mutable") . ")" ); if ( @classes ) { local $SIG{__WARN__} = sub {}; ( shift @classes )->meta->make_immutable; redo tests; } } done_testing; Point3D.pm100644000767000024 36412200352345 20412 0ustar00etherstaff000000000000Moose-2.1005/benchmarks/cmop/lib/MOP package MOP::Point3D; use strict; use warnings; use metaclass; use base 'MOP::Point'; __PACKAGE__->meta->add_attribute('z' => (accessor => 'z')); sub clear { my $self = shift; $self->SUPER::clear(); $self->z(0); } 1; __END__ Plain000755000767000024 012200352345 17061 5ustar00etherstaff000000000000Moose-2.1005/benchmarks/cmop/libPoint.pm100644000767000024 103412200352345 20646 0ustar00etherstaff000000000000Moose-2.1005/benchmarks/cmop/lib/Plain#!/usr/bin/perl package Plain::Point; use strict; use warnings; sub new { my ( $class, %params ) = @_; return bless { x => $params{x} || 10, y => $params{y}, }, $class; } sub x { my ( $self, @args ) = @_; if ( @args ) { $self->{x} = $args[0]; } return $self->{x}; } sub y { my ( $self, @args ) = @_; if ( @args ) { $self->{y} = $args[0]; } return $self->{y}; } sub clear { my $self = shift; @{$self}{qw/x y/} = (0, 0); } __PACKAGE__; __END__ AttributesWithHistory.pod100644000767000024 734212200352345 21231 0ustar00etherstaff000000000000Moose-2.1005/examples package # hide the package from PAUSE AttributesWithHistory; use strict; use warnings; our $VERSION = '0.05'; use base 'Class::MOP::Attribute'; # this is for an extra attribute constructor # option, which is to be able to create a # way for the class to access the history AttributesWithHistory->meta->add_attribute('history_accessor' => ( reader => 'history_accessor', init_arg => 'history_accessor', predicate => 'has_history_accessor', )); # this is a place to store the actual # history of the attribute AttributesWithHistory->meta->add_attribute('_history' => ( accessor => '_history', default => sub { {} }, )); sub accessor_metaclass { 'AttributesWithHistory::Method::Accessor' } AttributesWithHistory->meta->add_after_method_modifier('install_accessors' => sub { my ($self) = @_; # and now add the history accessor $self->associated_class->add_method( $self->_process_accessors('history_accessor' => $self->history_accessor()) ) if $self->has_history_accessor(); }); package # hide the package from PAUSE AttributesWithHistory::Method::Accessor; use strict; use warnings; our $VERSION = '0.01'; use base 'Class::MOP::Method::Accessor'; # generate the methods sub _generate_history_accessor_method { my $attr_name = (shift)->associated_attribute->name; eval qq{sub { unless (ref \$_[0]->meta->get_attribute('$attr_name')->_history()->\{\$_[0]\}) \{ \$_[0]->meta->get_attribute('$attr_name')->_history()->\{\$_[0]\} = []; \} \@\{\$_[0]->meta->get_attribute('$attr_name')->_history()->\{\$_[0]\}\}; }}; } sub _generate_accessor_method { my $attr_name = (shift)->associated_attribute->name; eval qq{sub { if (scalar(\@_) == 2) { unless (ref \$_[0]->meta->get_attribute('$attr_name')->_history()->\{\$_[0]\}) \{ \$_[0]->meta->get_attribute('$attr_name')->_history()->\{\$_[0]\} = []; \} push \@\{\$_[0]->meta->get_attribute('$attr_name')->_history()->\{\$_[0]\}\} => \$_[1]; \$_[0]->{'$attr_name'} = \$_[1]; } \$_[0]->{'$attr_name'}; }}; } sub _generate_writer_method { my $attr_name = (shift)->associated_attribute->name; eval qq{sub { unless (ref \$_[0]->meta->get_attribute('$attr_name')->_history()->\{\$_[0]\}) \{ \$_[0]->meta->get_attribute('$attr_name')->_history()->\{\$_[0]\} = []; \} push \@\{\$_[0]->meta->get_attribute('$attr_name')->_history()->\{\$_[0]\}\} => \$_[1]; \$_[0]->{'$attr_name'} = \$_[1]; }}; } 1; =pod =head1 NAME AttributesWithHistory - An example attribute metaclass which keeps a history of changes =head1 SYSNOPSIS package Foo; Foo->meta->add_attribute(AttributesWithHistory->new('foo' => ( accessor => 'foo', history_accessor => 'get_foo_history', ))); Foo->meta->add_attribute(AttributesWithHistory->new('bar' => ( reader => 'get_bar', writer => 'set_bar', history_accessor => 'get_bar_history', ))); sub new { my $class = shift; $class->meta->new_object(@_); } =head1 DESCRIPTION This is an example of an attribute metaclass which keeps a record of all the values it has been assigned. It stores the history as a field in the attribute meta-object, and will autogenerate a means of accessing that history for the class which these attributes are added too. =head1 AUTHORS Stevan Little Estevan@iinteractive.comE Yuval Kogman Enothingmuch@woobling.comE =head1 COPYRIGHT AND LICENSE Copyright 2006-2008 by Infinity Interactive, Inc. L This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut C3MethodDispatchOrder.pod100644000767000024 714212200352345 20745 0ustar00etherstaff000000000000Moose-2.1005/examples package # hide from PAUSE C3MethodDispatchOrder; use strict; use warnings; use Carp 'confess'; use Algorithm::C3; our $VERSION = '0.03'; use base 'Class::MOP::Class'; my $_find_method = sub { my ($class, $method) = @_; foreach my $super ($class->class_precedence_list) { return $super->meta->get_method($method) if $super->meta->has_method($method); } }; C3MethodDispatchOrder->meta->add_around_method_modifier('initialize' => sub { my $cont = shift; my $meta = $cont->(@_); # we need to look at $AUTOLOAD in the package where the coderef belongs # if subname works, then it'll be where this AUTOLOAD method was installed # otherwise, it'll be $C3MethodDispatchOrder::AUTOLOAD. get_code_info # tells us where AUTOLOAD will look my $autoload; $autoload = sub { my ($package) = Class::MOP::get_code_info($autoload); my $label = ${ $package->meta->get_package_symbol('$AUTOLOAD') }; my $method_name = (split /\:\:/ => $label)[-1]; my $method = $_find_method->($_[0]->meta, $method_name); (defined $method) || confess "Method ($method_name) not found"; goto &$method; }; $meta->add_method('AUTOLOAD' => $autoload) unless $meta->has_method('AUTOLOAD'); $meta->add_method('can' => sub { $_find_method->($_[0]->meta, $_[1]); }) unless $meta->has_method('can'); return $meta; }); sub superclasses { my $self = shift; $self->add_package_symbol('@SUPERS' => []) unless $self->has_package_symbol('@SUPERS'); if (@_) { my @supers = @_; @{$self->get_package_symbol('@SUPERS')} = @supers; } @{$self->get_package_symbol('@SUPERS')}; } sub class_precedence_list { my $self = shift; return map { $_->name; } Algorithm::C3::merge($self, sub { my $class = shift; map { $_->meta } $class->superclasses; }); } 1; __END__ =pod =head1 NAME C3MethodDispatchOrder - An example attribute metaclass for changing to C3 method dispatch order =head1 SYNOPSIS # a classic diamond inheritence graph # # # / \ # # \ / # package A; use metaclass 'C3MethodDispatchOrder'; sub hello { return "Hello from A" } package B; use metaclass 'C3MethodDispatchOrder'; B->meta->superclasses('A'); package C; use metaclass 'C3MethodDispatchOrder'; C->meta->superclasses('A'); sub hello { return "Hello from C" } package D; use metaclass 'C3MethodDispatchOrder'; D->meta->superclasses('B', 'C'); print join ", " => D->meta->class_precedence_list; # prints C3 order D, B, C, A # later in other code ... print D->hello; # print 'Hello from C' instead of the normal 'Hello from A' =head1 DESCRIPTION This is an example of how you could change the method dispatch order of a class using L. Using the L module, this repleces the normal depth-first left-to-right perl dispatch order with the C3 method dispatch order (see the L or L docs for more information about this). This example could be used as a template for other method dispatch orders as well, all that is required is to write a the C method which will return a linearized list of classes to dispatch along. =head1 AUTHORS Stevan Little Estevan@iinteractive.comE Yuval Kogman Enothingmuch@woobling.comE =head1 COPYRIGHT AND LICENSE Copyright 2006-2008 by Infinity Interactive, Inc. L This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut InstanceCountingClass.pod100644000767000024 243412200352345 21123 0ustar00etherstaff000000000000Moose-2.1005/examples package # hide the package from PAUSE InstanceCountingClass; use strict; use warnings; our $VERSION = '0.03'; use base 'Class::MOP::Class'; InstanceCountingClass->meta->add_attribute('count' => ( reader => 'get_count', default => 0 )); InstanceCountingClass->meta->add_before_method_modifier('_construct_instance' => sub { my ($class) = @_; $class->{'count'}++; }); 1; __END__ =pod =head1 NAME InstanceCountingClass - An example metaclass which counts instances =head1 SYNOPSIS package Foo; use metaclass 'InstanceCountingClass'; sub new { my $class = shift; $class->meta->new_object(@_); } # ... meanwhile, somewhere in the code my $foo = Foo->new(); print Foo->meta->get_count(); # prints 1 my $foo2 = Foo->new(); print Foo->meta->get_count(); # prints 2 # ... etc etc etc =head1 DESCRIPTION This is a classic example of a metaclass which keeps a count of each instance which is created. =head1 AUTHORS Stevan Little Estevan@iinteractive.comE Yuval Kogman Enothingmuch@woobling.comE =head1 COPYRIGHT AND LICENSE Copyright 2006-2008 by Infinity Interactive, Inc. L This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut Snack000755000767000024 012200352345 16632 5ustar00etherstaff000000000000Moose-2.1005/lib/Moose/CookbookTypes.pod100644000767000024 400212200352345 20576 0ustar00etherstaff000000000000Moose-2.1005/lib/Moose/Cookbook/Snackpackage Moose::Cookbook::Snack::Types; # ABSTRACT: Snippets of code for using Types and Type Constraints __END__ =pod =head1 NAME Moose::Cookbook::Snack::Types - Snippets of code for using Types and Type Constraints =head1 VERSION version 2.1005 =head1 SYNOPSIS package Point; use Moose; has 'x' => ( isa => 'Int', is => 'ro' ); has 'y' => ( isa => 'Int', is => 'rw' ); package main; use Try::Tiny; my $point = try { Point->new( x => 'fifty', y => 'forty' ); } catch { print "Oops: $_"; }; my $point; my $xval = 'forty-two'; my $xattribute = Point->meta->find_attribute_by_name('x'); my $xtype_constraint = $xattribute->type_constraint; if ( $xtype_constraint->check($xval) ) { $point = Point->new( x => $xval, y => 0 ); } else { print "Value: $xval is not an " . $xtype_constraint->name . "\n"; } =head1 DESCRIPTION This is the Point example from L with type checking added. If we try to assign a string value to an attribute that is an C, Moose will die with an explicit error message. The error will include the attribute name, as well as the type constraint name and the value which failed the constraint check. We use L to catch this error message. Later, we get the L object from a L and use the L to check a value directly. =head1 SEE ALSO =over 4 =item L =item L =item L =back =head1 AUTHOR Moose is maintained by the Moose Cabal, along with the help of many contributors. See L and L for details. =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2013 by Infinity Interactive, Inc.. This is free software; you can redistribute it and/or modify it under the same terms as the Perl 5 programming language system itself. =cut BestPractices.pod100644000767000024 2015512200352345 20664 0ustar00etherstaff000000000000Moose-2.1005/lib/Moose/Manualpackage Moose::Manual::BestPractices; # ABSTRACT: Get the most out of Moose __END__ =pod =head1 NAME Moose::Manual::BestPractices - Get the most out of Moose =head1 VERSION version 2.1005 =head1 RECOMMENDATIONS Moose has a lot of features, and there's definitely more than one way to do it. However, we think that picking a subset of these features and using them consistently makes everyone's life easier. Of course, as with any list of "best practices", these are really just opinions. Feel free to ignore us. =head2 C and immutabilize We recommend that you remove the Moose sugar and end your Moose class definitions by making your class immutable. package Person; use Moose; use namespace::autoclean; # extends, roles, attributes, etc. # methods __PACKAGE__->meta->make_immutable; 1; The C bit is simply good code hygiene, as it removes imported symbols from your class's namespace at the end of your package's compile cycle, including Moose keywords. Once the class has been built, these keywords are not needed. (This is preferred to placing C at the end of your package). The C call allows Moose to speed up a lot of things, most notably object construction. The trade-off is that you can no longer change the class definition. =head2 Never override C Overriding C is a very bad practice. Instead, you should use a C or C methods to do the same thing. When you override C, Moose can no longer inline a constructor when your class is immutabilized. There are two good reasons to override C. One, you are writing a MooseX extension that provides its own L subclass I a subclass of L to inline the constructor. Two, you are subclassing a non-Moose parent. If you know how to do that, you know when to ignore this best practice ;) =head2 Always call the original/parent C If you C the C method in your class, make sure to play nice and call C to handle cases you're not checking for explicitly. The default C method in L handles both a list and hashref of named parameters correctly, and also checks for a I single argument. =head2 Provide defaults whenever possible, otherwise use C When your class provides defaults, this makes constructing new objects simpler. If you cannot provide a default, consider making the attribute C. If you don't do either, an attribute can simply be left unset, increasing the complexity of your object, because it has more possible states that you or the user of your class must account for. =head2 Use C instead of C most of the time Builders can be inherited, they have explicit names, and they're just plain cleaner. However, I use a default when the default is a non-reference, I when the default is simply an empty reference of some sort. Also, keep your builder methods private. =head2 Be C Lazy is good, and often solves initialization ordering problems. It's also good for deferring work that may never have to be done. Make your attributes C unless they're C or have trivial defaults. =head2 Consider keeping clearers and predicates private Does everyone I need to be able to clear an attribute? Probably not. Don't expose this functionality outside your class by default. Predicates are less problematic, but there's no reason to make your public API bigger than it has to be. =head2 Avoid C As described above, you rarely actually need a clearer or a predicate. C adds both to your public API, which exposes you to use cases that you must now test for. It's much better to avoid adding them until you really need them - use explicit C and C options instead. =head2 Default to read-only, and consider keeping writers private Making attributes mutable just means more complexity to account for in your program. The alternative to mutable state is to encourage users of your class to simply make new objects as needed. If you I make an attribute read-write, consider making the writer a separate private method. Narrower APIs are easy to maintain, and mutable state is trouble. In order to declare such attributes, provide a private C parameter: has pizza => ( is => 'ro', isa => 'Pizza', writer => '_pizza', ); =head2 Think twice before changing an attribute's type in a subclass Down this path lies great confusion. If the attribute is an object itself, at least make sure that it has the same interface as the type of object in the parent class. =head2 Don't use the C feature Don't know what we're talking about? That's fine. =head2 Use L traits instead of C The C feature is a bit troublesome. Directly exposing a complex attribute is ugly. Instead, consider using L traits to define an API that only exposes the necessary pieces of functionality. =head2 Always call C in the most specific subclass When using C and C, we recommend that you call C in the most specific subclass of your hierarchy. This makes it possible to subclass further and extend the hierarchy without changing the parents. =head2 Namespace your types Use some sort of namespacing convention for type names. We recommend something like "MyApp::Type::Foo". We also recommend considering L. =head2 Do not coerce Moose built-ins directly If you define a coercion for a Moose built-in like C, this will affect every application in the Perl interpreter that uses this type. # very naughty! coerce 'ArrayRef' => from Str => via { [ split /,/ ] }; Instead, create a subtype and coerce that: subtype 'My::ArrayRef' => as 'ArrayRef'; coerce 'My::ArrayRef' => from 'Str' => via { [ split /,/ ] }; =head2 Do not coerce class names directly Just as with Moose built-in types, a class type is global for the entire interpreter. If you add a coercion for that class name, it can have magical side effects elsewhere: # also very naughty! coerce 'HTTP::Headers' => from 'HashRef' => via { HTTP::Headers->new( %{$_} ) }; Instead, we can create an "empty" subtype for the coercion: subtype 'My::HTTP::Headers' => as class_type('HTTP::Headers'); coerce 'My::HTTP::Headers' => from 'HashRef' => via { HTTP::Headers->new( %{$_} ) }; =head2 Use coercion instead of unions Consider using a type coercion instead of a type union. This was covered in L. =head2 Define all your types in one module Define all your types and coercions in one module. This was also covered in L. =head1 BENEFITS OF BEST PRACTICES Following these practices has a number of benefits. It helps ensure that your code will play nice with others, making it more reusable and easier to extend. Following an accepted set of idioms will make maintenance easier, especially when someone else has to maintain your code. It will also make it easier to get support from other Moose users, since your code will be easier to digest quickly. Some of these practices are designed to help Moose do the right thing, especially when it comes to immutabilization. This means your code will be faster when immutabilized. Many of these practices also help get the most out of meta programming. If you used an overridden C to do type coercion by hand, rather than defining a real coercion, there is no introspectable metadata. This sort of thing is particularly problematic for MooseX extensions which rely on introspection to do the right thing. =head1 AUTHOR Moose is maintained by the Moose Cabal, along with the help of many contributors. See L and L for details. =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2013 by Infinity Interactive, Inc.. This is free software; you can redistribute it and/or modify it under the same terms as the Perl 5 programming language system itself. =cut Attribute000755000767000024 012200352345 16656 5ustar00etherstaff000000000000Moose-2.1005/lib/Moose/MetaNative.pm100644000767000024 1640612200352345 20631 0ustar00etherstaff000000000000Moose-2.1005/lib/Moose/Meta/Attributepackage Moose::Meta::Attribute::Native; BEGIN { $Moose::Meta::Attribute::Native::AUTHORITY = 'cpan:STEVAN'; } { $Moose::Meta::Attribute::Native::VERSION = '2.1005'; } use Class::Load qw(load_class); my @trait_names = qw(Bool Counter Number String Array Hash Code); for my $trait_name (@trait_names) { my $trait_class = "Moose::Meta::Attribute::Native::Trait::$trait_name"; my $meta = Class::MOP::Class->initialize( "Moose::Meta::Attribute::Custom::Trait::$trait_name" ); if ($meta->find_method_by_name('register_implementation')) { my $class = $meta->name->register_implementation; Moose->throw_error( "An implementation for $trait_name already exists " . "(found '$class' when trying to register '$trait_class')" ); } $meta->add_method(register_implementation => sub { # resolve_metatrait_alias will load classes anyway, but throws away # their error message; we WANT to die if there's a problem load_class($trait_class); return $trait_class; }); } 1; # ABSTRACT: Delegate to native Perl types __END__ =pod =head1 NAME Moose::Meta::Attribute::Native - Delegate to native Perl types =head1 VERSION version 2.1005 =head1 SYNOPSIS package MyClass; use Moose; has 'mapping' => ( traits => ['Hash'], is => 'rw', isa => 'HashRef[Str]', default => sub { {} }, handles => { exists_in_mapping => 'exists', ids_in_mapping => 'keys', get_mapping => 'get', set_mapping => 'set', set_quantity => [ set => 'quantity' ], }, ); my $obj = MyClass->new; $obj->set_quantity(10); # quantity => 10 $obj->set_mapping('foo', 4); # foo => 4 $obj->set_mapping('bar', 5); # bar => 5 $obj->set_mapping('baz', 6); # baz => 6 # prints 5 print $obj->get_mapping('bar') if $obj->exists_in_mapping('bar'); # prints 'quantity, foo, bar, baz' print join ', ', $obj->ids_in_mapping; =head1 DESCRIPTION Native delegations allow you to delegate to native Perl data structures as if they were objects. For example, in the L you can see a hash reference being treated as if it has methods named C, C, C, and C. The delegation methods (mostly) map to Perl builtins and operators. The return values of these delegations should be the same as the corresponding Perl operation. Any deviations will be explicitly documented. =head1 API Native delegations are enabled by passing certain options to C when creating an attribute. =head2 traits To enable this feature, pass the appropriate name in the C array reference for the attribute. For example, to enable this feature for hash reference, we include C<'Hash'> in the list of traits. =head2 isa You will need to make sure that the attribute has an appropriate type. For example, to use this with a Hash you must specify that your attribute is some sort of C. =head2 handles This is just like any other delegation, but only a hash reference is allowed when defining native delegations. The keys are the methods to be created in the class which contains the attribute. The values are the methods provided by the associated trait. Currying works the same way as it does with any other delegation. See the docs for each native trait for details on what methods are available. =head2 is Some traits provide a default C for historical reasons. This behavior is deprecated, and you are strongly encouraged to provide a value. If you don't plan to read and write the attribute value directly, not passing the C option will prevent standard accessor generation. =head2 default or builder Some traits provide a default C for historical reasons. This behavior is deprecated, and you are strongly encouraged to provide a default value or make the attribute required. =head1 TRAITS FOR NATIVE DELEGATIONS Below are some simple examples of each native trait. More features are available than what is shown here; this is just a quick synopsis. =over =item Array (L) has 'queue' => ( traits => ['Array'], is => 'ro', isa => 'ArrayRef[Str]', default => sub { [] }, handles => { add_item => 'push', next_item => 'shift', # ... } ); =item Bool (L) has 'is_lit' => ( traits => ['Bool'], is => 'ro', isa => 'Bool', default => 0, handles => { illuminate => 'set', darken => 'unset', flip_switch => 'toggle', is_dark => 'not', # ... } ); =item Code (L) has 'callback' => ( traits => ['Code'], is => 'ro', isa => 'CodeRef', default => sub { sub {'called'} }, handles => { call => 'execute', # ... } ); =item Counter (L) has 'counter' => ( traits => ['Counter'], is => 'ro', isa => 'Num', default => 0, handles => { inc_counter => 'inc', dec_counter => 'dec', reset_counter => 'reset', # ... } ); =item Hash (L) has 'options' => ( traits => ['Hash'], is => 'ro', isa => 'HashRef[Str]', default => sub { {} }, handles => { set_option => 'set', get_option => 'get', has_option => 'exists', # ... } ); =item Number (L) has 'integer' => ( traits => ['Number'], is => 'ro', isa => 'Int', default => 5, handles => { set => 'set', add => 'add', sub => 'sub', mul => 'mul', div => 'div', mod => 'mod', abs => 'abs', # ... } ); =item String (L) has 'text' => ( traits => ['String'], is => 'ro', isa => 'Str', default => q{}, handles => { add_text => 'append', replace_text => 'replace', # ... } ); =back =head1 COMPATIBILITY WITH MooseX::AttributeHelpers This feature used to be a separated CPAN distribution called L. When the feature was incorporated into the Moose core, some of the API details were changed. The underlying capabilities are the same, but some details of the API were changed. =head1 BUGS See L for details on reporting bugs. =head1 AUTHOR Moose is maintained by the Moose Cabal, along with the help of many contributors. See L and L for details. =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2013 by Infinity Interactive, Inc.. This is free software; you can redistribute it and/or modify it under the same terms as the Perl 5 programming language system itself. =cut Augmented.pm100644000767000024 622112200352345 20543 0ustar00etherstaff000000000000Moose-2.1005/lib/Moose/Meta/Methodpackage Moose::Meta::Method::Augmented; BEGIN { $Moose::Meta::Method::Augmented::AUTHORITY = 'cpan:STEVAN'; } { $Moose::Meta::Method::Augmented::VERSION = '2.1005'; } use strict; use warnings; use base 'Moose::Meta::Method'; sub new { my ( $class, %args ) = @_; # the package can be overridden by roles # it is really more like body's compilation stash # this is where we need to override the definition of super() so that the # body of the code can call the right overridden version my $name = $args{name}; my $meta = $args{class}; my $super = $meta->find_next_method_by_name($name); (defined $super) || $meta->throw_error("You cannot augment '$name' because it has no super method", data => $name); my $_super_package = $super->package_name; # BUT!,... if this is an overridden method .... if ($super->isa('Moose::Meta::Method::Overridden')) { # we need to be sure that we actually # find the next method, which is not # an 'override' method, the reason is # that an 'override' method will not # be the one calling inner() my $real_super = $meta->_find_next_method_by_name_which_is_not_overridden($name); $_super_package = $real_super->package_name; } my $super_body = $super->body; my $method = $args{method}; my $body = sub { local $Moose::INNER_ARGS{$_super_package} = [ @_ ]; local $Moose::INNER_BODY{$_super_package} = $method; $super_body->(@_); }; # FIXME store additional attrs $class->wrap( $body, package_name => $meta->name, name => $name ); } 1; # ABSTRACT: A Moose Method metaclass for augmented methods __END__ =pod =head1 NAME Moose::Meta::Method::Augmented - A Moose Method metaclass for augmented methods =head1 VERSION version 2.1005 =head1 DESCRIPTION This class implements method augmentation logic for the L C keyword. The augmentation subroutine reference will be invoked explicitly using the C keyword from the parent class's method definition. =head1 INHERITANCE C is a subclass of L. =head1 METHODS =over 4 =item B<< Moose::Meta::Method::Augmented->new(%options) >> This constructs a new object. It accepts the following options: =over 8 =item * class The metaclass object for the class in which the augmentation is being declared. This option is required. =item * name The name of the method which we are augmenting. This method must exist in one of the class's superclasses. This option is required. =item * method The subroutine reference which implements the augmentation. This option is required. =back =back =head1 BUGS See L for details on reporting bugs. =head1 AUTHOR Moose is maintained by the Moose Cabal, along with the help of many contributors. See L and L for details. =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2013 by Infinity Interactive, Inc.. This is free software; you can redistribute it and/or modify it under the same terms as the Perl 5 programming language system itself. =cut Application.pm100644000767000024 717312200352345 20565 0ustar00etherstaff000000000000Moose-2.1005/lib/Moose/Meta/Rolepackage Moose::Meta::Role::Application; BEGIN { $Moose::Meta::Role::Application::AUTHORITY = 'cpan:STEVAN'; } { $Moose::Meta::Role::Application::VERSION = '2.1005'; } use strict; use warnings; use metaclass; __PACKAGE__->meta->add_attribute('method_exclusions' => ( init_arg => '-excludes', reader => 'get_method_exclusions', default => sub { [] }, Class::MOP::_definition_context(), )); __PACKAGE__->meta->add_attribute('method_aliases' => ( init_arg => '-alias', reader => 'get_method_aliases', default => sub { {} }, Class::MOP::_definition_context(), )); sub new { my ($class, %params) = @_; $class->_new(\%params); } sub is_method_excluded { my ($self, $method_name) = @_; foreach (@{$self->get_method_exclusions}) { return 1 if $_ eq $method_name; } return 0; } sub is_method_aliased { my ($self, $method_name) = @_; exists $self->get_method_aliases->{$method_name} ? 1 : 0 } sub is_aliased_method { my ($self, $method_name) = @_; my %aliased_names = reverse %{$self->get_method_aliases}; exists $aliased_names{$method_name} ? 1 : 0; } sub apply { my $self = shift; $self->check_role_exclusions(@_); $self->check_required_methods(@_); $self->check_required_attributes(@_); $self->apply_attributes(@_); $self->apply_methods(@_); $self->apply_override_method_modifiers(@_); $self->apply_before_method_modifiers(@_); $self->apply_around_method_modifiers(@_); $self->apply_after_method_modifiers(@_); } sub check_role_exclusions { Carp::croak "Abstract Method" } sub check_required_methods { Carp::croak "Abstract Method" } sub check_required_attributes { Carp::croak "Abstract Method" } sub apply_attributes { Carp::croak "Abstract Method" } sub apply_methods { Carp::croak "Abstract Method" } sub apply_override_method_modifiers { Carp::croak "Abstract Method" } sub apply_method_modifiers { Carp::croak "Abstract Method" } sub apply_before_method_modifiers { (shift)->apply_method_modifiers('before' => @_) } sub apply_around_method_modifiers { (shift)->apply_method_modifiers('around' => @_) } sub apply_after_method_modifiers { (shift)->apply_method_modifiers('after' => @_) } 1; # ABSTRACT: A base class for role application __END__ =pod =head1 NAME Moose::Meta::Role::Application - A base class for role application =head1 VERSION version 2.1005 =head1 DESCRIPTION This is the abstract base class for role applications. The API for this class and its subclasses still needs some consideration, and is intentionally not yet documented. =head2 METHODS =over 4 =item B =item B =item B =item B =item B =item B =item B =item B =item B =item B =item B =item B =item B =item B =item B =item B =item B =item B =back =head1 BUGS See L for details on reporting bugs. =head1 AUTHOR Moose is maintained by the Moose Cabal, along with the help of many contributors. See L and L for details. =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2013 by Infinity Interactive, Inc.. This is free software; you can redistribute it and/or modify it under the same terms as the Perl 5 programming language system itself. =cut handles_foreign_class_bug.t100644000767000024 355712200352345 21110 0ustar00etherstaff000000000000Moose-2.1005/t/bugs#!/usr/bin/perl use strict; use warnings; use Test::More; use Test::Fatal; { package Foo; sub new { bless({}, 'Foo') } sub a { 'Foo::a' } } { package Bar; use Moose; ::is( ::exception { has 'baz' => ( is => 'ro', isa => 'Foo', lazy => 1, default => sub { Foo->new() }, handles => qr/^a$/, ); }, undef, '... can create the attribute with delegations' ); } my $bar; is( exception { $bar = Bar->new; }, undef, '... created the object ok' ); isa_ok($bar, 'Bar'); is($bar->a, 'Foo::a', '... got the right delgated value'); my @w; $SIG{__WARN__} = sub { push @w, "@_" }; { package Baz; use Moose; ::is( ::exception { has 'bar' => ( is => 'ro', isa => 'Foo', lazy => 1, default => sub { Foo->new() }, handles => qr/.*/, ); }, undef, '... can create the attribute with delegations' ); } is(@w, 0, "no warnings"); my $baz; is( exception { $baz = Baz->new; }, undef, '... created the object ok' ); isa_ok($baz, 'Baz'); is($baz->a, 'Foo::a', '... got the right delgated value'); @w = (); { package Blart; use Moose; ::is( ::exception { has 'bar' => ( is => 'ro', isa => 'Foo', lazy => 1, default => sub { Foo->new() }, handles => [qw(a new)], ); }, undef, '... can create the attribute with delegations' ); } { local $TODO = "warning not yet implemented"; is(@w, 1, "one warning"); like($w[0], qr/not delegating.*new/i, "warned"); } my $blart; is( exception { $blart = Blart->new; }, undef, '... created the object ok' ); isa_ok($blart, 'Blart'); is($blart->a, 'Foo::a', '... got the right delgated value'); done_testing; before_after_dollar_under.t100644000767000024 347712200352345 21113 0ustar00etherstaff000000000000Moose-2.1005/t/cmopuse strict; use warnings; use Class::MOP; use Class::MOP::Class; use Test::More; use Test::Fatal; my %results; { package Base; use metaclass; sub hey { $results{base}++ } } for my $wrap (qw(before after)) { my $meta = Class::MOP::Class->create_anon_class( superclasses => [ 'Base', 'Class::MOP::Object' ] ); my $alter = "add_${wrap}_method_modifier"; $meta->$alter( 'hey' => sub { $results{wrapped}++; $_ = 'barf'; # 'barf' would replace the cached wrapper subref } ); %results = (); my $o = $meta->get_meta_instance->create_instance; isa_ok( $o, 'Base' ); is( exception { $o->hey; $o->hey ; # this would die with 'Can't use string ("barf") as a subroutine ref while "strict refs" in use' }, undef, 'wrapped doesn\'t die when $_ gets changed' ); is_deeply( \%results, { base => 2, wrapped => 2 }, 'saw expected calls to wrappers' ); } { my $meta = Class::MOP::Class->create_anon_class( superclasses => [ 'Base', 'Class::MOP::Object' ] ); for my $wrap (qw(before after)) { my $alter = "add_${wrap}_method_modifier"; $meta->$alter( 'hey' => sub { $results{wrapped}++; $_ = 'barf'; # 'barf' would replace the cached wrapper subref } ); } %results = (); my $o = $meta->get_meta_instance->create_instance; isa_ok( $o, 'Base' ); is( exception { $o->hey; $o->hey ; # this would die with 'Can't use string ("barf") as a subroutine ref while "strict refs" in use' }, undef, 'double-wrapped doesn\'t die when $_ gets changed' ); is_deeply( \%results, { base => 2, wrapped => 4 }, 'saw expected calls to wrappers' ); } done_testing; metaclass_incompatibility.t100644000767000024 2125512200352345 21204 0ustar00etherstaff000000000000Moose-2.1005/t/cmopuse strict; use warnings; use Test::More; use Test::Fatal; use metaclass; my %metaclass_attrs; BEGIN { %metaclass_attrs = ( 'Instance' => 'instance_metaclass', 'Attribute' => 'attribute_metaclass', 'Method' => 'method_metaclass', 'Method::Wrapped' => 'wrapped_method_metaclass', 'Method::Constructor' => 'constructor_class', ); # meta classes for my $suffix ('Class', keys %metaclass_attrs) { Class::MOP::Class->create( "Foo::Meta::$suffix", superclasses => ["Class::MOP::$suffix"] ); $INC{"Foo/Meta/$suffix.pm"} = __FILE__; Class::MOP::Class->create( "Bar::Meta::$suffix", superclasses => ["Class::MOP::$suffix"] ); $INC{"Bar/Meta/$suffix.pm"} = __FILE__; Class::MOP::Class->create( "FooBar::Meta::$suffix", superclasses => ["Foo::Meta::$suffix", "Bar::Meta::$suffix"] ); $INC{"FooBar/Meta/$suffix.pm"} = __FILE__; } } # checking... is( exception { Foo::Meta::Class->create('Foo') }, undef, '... Foo.meta => Foo::Meta::Class is compatible' ); is( exception { Bar::Meta::Class->create('Bar') }, undef, '... Bar.meta => Bar::Meta::Class is compatible' ); like( exception { Bar::Meta::Class->create('Foo::Foo', superclasses => ['Foo']) }, qr/compatible/, '... Foo::Foo.meta => Bar::Meta::Class is not compatible' ); like( exception { Foo::Meta::Class->create('Bar::Bar', superclasses => ['Bar']) }, qr/compatible/, '... Bar::Bar.meta => Foo::Meta::Class is not compatible' ); is( exception { FooBar::Meta::Class->create('FooBar', superclasses => ['Foo']) }, undef, '... FooBar.meta => FooBar::Meta::Class is compatible' ); is( exception { FooBar::Meta::Class->create('FooBar2', superclasses => ['Bar']) }, undef, '... FooBar2.meta => FooBar::Meta::Class is compatible' ); Foo::Meta::Class->create( 'Foo::All', map { $metaclass_attrs{$_} => "Foo::Meta::$_" } keys %metaclass_attrs, ); like( exception { Bar::Meta::Class->create( 'Foo::All::Sub::Class', superclasses => ['Foo::All'], map { $metaclass_attrs{$_} => "Foo::Meta::$_" } keys %metaclass_attrs, ) }, qr/compatible/, 'incompatible Class metaclass' ); for my $suffix (keys %metaclass_attrs) { like( exception { Foo::Meta::Class->create( "Foo::All::Sub::$suffix", superclasses => ['Foo::All'], (map { $metaclass_attrs{$_} => "Foo::Meta::$_" } keys %metaclass_attrs), $metaclass_attrs{$suffix} => "Bar::Meta::$suffix", ) }, qr/compatible/, "incompatible $suffix metaclass" ); } # fixing... is( exception { Class::MOP::Class->create('Foo::Foo::CMOP', superclasses => ['Foo']) }, undef, 'metaclass fixing fixes a cmop metaclass, when the parent has a subclass' ); isa_ok(Foo::Foo::CMOP->meta, 'Foo::Meta::Class'); is( exception { Class::MOP::Class->create('Bar::Bar::CMOP', superclasses => ['Bar']) }, undef, 'metaclass fixing fixes a cmop metaclass, when the parent has a subclass' ); isa_ok(Bar::Bar::CMOP->meta, 'Bar::Meta::Class'); is( exception { Class::MOP::Class->create( 'Foo::All::Sub::CMOP::Class', superclasses => ['Foo::All'], map { $metaclass_attrs{$_} => "Foo::Meta::$_" } keys %metaclass_attrs, ) }, undef, 'metaclass fixing works with other non-default metaclasses' ); isa_ok(Foo::All::Sub::CMOP::Class->meta, 'Foo::Meta::Class'); for my $suffix (keys %metaclass_attrs) { is( exception { Foo::Meta::Class->create( "Foo::All::Sub::CMOP::$suffix", superclasses => ['Foo::All'], (map { $metaclass_attrs{$_} => "Foo::Meta::$_" } keys %metaclass_attrs), $metaclass_attrs{$suffix} => "Class::MOP::$suffix", ) }, undef, "$metaclass_attrs{$suffix} fixing works with other non-default metaclasses" ); for my $suffix2 (keys %metaclass_attrs) { my $method = $metaclass_attrs{$suffix2}; isa_ok("Foo::All::Sub::CMOP::$suffix"->meta->$method, "Foo::Meta::$suffix2"); } } # initializing... { package Foo::NoMeta; } Class::MOP::Class->create('Foo::NoMeta::Sub', superclasses => ['Foo::NoMeta']); ok(!Foo::NoMeta->can('meta'), "non-cmop superclass doesn't get methods installed"); isa_ok(Class::MOP::class_of('Foo::NoMeta'), 'Class::MOP::Class'); isa_ok(Foo::NoMeta::Sub->meta, 'Class::MOP::Class'); { package Foo::NoMeta2; } Foo::Meta::Class->create('Foo::NoMeta2::Sub', superclasses => ['Foo::NoMeta2']); ok(!Foo::NoMeta->can('meta'), "non-cmop superclass doesn't get methods installed"); isa_ok(Class::MOP::class_of('Foo::NoMeta2'), 'Class::MOP::Class'); isa_ok(Foo::NoMeta2::Sub->meta, 'Foo::Meta::Class'); BEGIN { Foo::Meta::Class->create('Foo::WithMeta'); $INC{'Foo/WithMeta.pm'} = __FILE__; } { package Foo::WithMeta::Sub; use base 'Foo::WithMeta'; } Class::MOP::Class->create( 'Foo::WithMeta::Sub::Sub', superclasses => ['Foo::WithMeta::Sub'] ); isa_ok(Class::MOP::class_of('Foo::WithMeta'), 'Foo::Meta::Class'); isa_ok(Class::MOP::class_of('Foo::WithMeta::Sub'), 'Foo::Meta::Class'); isa_ok(Class::MOP::class_of('Foo::WithMeta::Sub::Sub'), 'Foo::Meta::Class'); BEGIN { Foo::Meta::Class->create('Foo::WithMeta2'); $INC{'Foo/WithMeta2.pm'} = __FILE__; } { package Foo::WithMeta2::Sub; use base 'Foo::WithMeta2'; } { package Foo::WithMeta2::Sub::Sub; use base 'Foo::WithMeta2::Sub'; } Class::MOP::Class->create( 'Foo::WithMeta2::Sub::Sub::Sub', superclasses => ['Foo::WithMeta2::Sub::Sub'] ); isa_ok(Class::MOP::class_of('Foo::WithMeta2'), 'Foo::Meta::Class'); isa_ok(Class::MOP::class_of('Foo::WithMeta2::Sub'), 'Foo::Meta::Class'); isa_ok(Class::MOP::class_of('Foo::WithMeta2::Sub::Sub'), 'Foo::Meta::Class'); isa_ok(Class::MOP::class_of('Foo::WithMeta2::Sub::Sub::Sub'), 'Foo::Meta::Class'); Class::MOP::Class->create( 'Foo::Reverse::Sub::Sub', superclasses => ['Foo::Reverse::Sub'], ); eval "package Foo::Reverse::Sub; use base 'Foo::Reverse';"; Foo::Meta::Class->create( 'Foo::Reverse', ); isa_ok(Class::MOP::class_of('Foo::Reverse'), 'Foo::Meta::Class'); { local $TODO = 'No idea how to handle case where child class is created before parent'; isa_ok(Class::MOP::class_of('Foo::Reverse::Sub'), 'Foo::Meta::Class'); isa_ok(Class::MOP::class_of('Foo::Reverse::Sub::Sub'), 'Foo::Meta::Class'); } # unsafe fixing... { Class::MOP::Class->create( 'Foo::Unsafe', attribute_metaclass => 'Foo::Meta::Attribute', ); my $meta = Class::MOP::Class->create( 'Foo::Unsafe::Sub', ); $meta->add_attribute(foo => reader => 'foo'); like( exception { $meta->superclasses('Foo::Unsafe') }, qr/compatibility.*pristine/, "can't switch out the attribute metaclass of a class that already has attributes" ); } # immutability... { my $foometa = Foo::Meta::Class->create( 'Foo::Immutable', ); $foometa->make_immutable; my $barmeta = Class::MOP::Class->create( 'Bar::Mutable', ); my $bazmeta = Class::MOP::Class->create( 'Baz::Mutable', ); $bazmeta->superclasses($foometa->name); is( exception { $bazmeta->superclasses($barmeta->name) }, undef, "can still set superclasses" ); ok(!$bazmeta->is_immutable, "immutable superclass doesn't make this class immutable"); is( exception { $bazmeta->make_immutable }, undef, "can still make immutable" ); } # nonexistent metaclasses Class::MOP::Class->create( 'Weird::Meta::Method::Destructor', superclasses => ['Class::MOP::Method'], ); is( exception { Class::MOP::Class->create( 'Weird::Class', destructor_class => 'Weird::Meta::Method::Destructor', ); }, undef, "defined metaclass in child with defined metaclass in parent is fine" ); is(Weird::Class->meta->destructor_class, 'Weird::Meta::Method::Destructor', "got the right destructor class"); is( exception { Class::MOP::Class->create( 'Weird::Class::Sub', superclasses => ['Weird::Class'], destructor_class => undef, ); }, undef, "undef metaclass in child with defined metaclass in parent can be fixed" ); is(Weird::Class::Sub->meta->destructor_class, 'Weird::Meta::Method::Destructor', "got the right destructor class"); is( exception { Class::MOP::Class->create( 'Weird::Class::Sub2', destructor_class => undef, ); }, undef, "undef metaclass in child with defined metaclass in parent can be fixed" ); is( exception { Weird::Class::Sub2->meta->superclasses('Weird::Class'); }, undef, "undef metaclass in child with defined metaclass in parent can be fixed" ); is(Weird::Class::Sub->meta->destructor_class, 'Weird::Meta::Method::Destructor', "got the right destructor class"); done_testing; new_and_clone_metaclasses.t100644000767000024 666412200352345 21116 0ustar00etherstaff000000000000Moose-2.1005/t/cmopuse strict; use warnings; use FindBin; use File::Spec::Functions; use Test::More; use Test::Fatal; use Class::MOP; use lib catdir($FindBin::Bin, 'lib'); # make sure the Class::MOP::Class->meta does the right thing my $meta = Class::MOP::Class->meta(); isa_ok($meta, 'Class::MOP::Class'); my $new_meta = $meta->new_object('package' => 'Class::MOP::Class'); isa_ok($new_meta, 'Class::MOP::Class'); is($new_meta, $meta, '... it still creates the singleton'); my $cloned_meta = $meta->clone_object($meta); isa_ok($cloned_meta, 'Class::MOP::Class'); is($cloned_meta, $meta, '... it creates the singleton even if you try to clone it'); # make sure other metaclasses do the right thing { package Foo; use metaclass; } my $foo_meta = Foo->meta; isa_ok($foo_meta, 'Class::MOP::Class'); is($meta->new_object('package' => 'Foo'), $foo_meta, '... got the right Foo->meta singleton'); is($meta->clone_object($foo_meta), $foo_meta, '... cloning got the right Foo->meta singleton'); # make sure subclassed of Class::MOP::Class do the right thing my $my_meta = MyMetaClass->meta; isa_ok($my_meta, 'Class::MOP::Class'); my $new_my_meta = $my_meta->new_object('package' => 'MyMetaClass'); isa_ok($new_my_meta, 'Class::MOP::Class'); is($new_my_meta, $my_meta, '... even subclasses still create the singleton'); my $cloned_my_meta = $meta->clone_object($my_meta); isa_ok($cloned_my_meta, 'Class::MOP::Class'); is($cloned_my_meta, $my_meta, '... and subclasses creates the singleton even if you try to clone it'); is($my_meta->new_object('package' => 'Foo'), $foo_meta, '... got the right Foo->meta singleton (w/subclass)'); is($meta->clone_object($foo_meta), $foo_meta, '... cloning got the right Foo->meta singleton (w/subclass)'); # now create a metaclass for real my $bar_meta = $my_meta->new_object('package' => 'Bar'); isa_ok($bar_meta, 'Class::MOP::Class'); is($bar_meta->name, 'Bar', '... got the right name for the Bar metaclass'); is($bar_meta->version, undef, '... Bar does not exists, so it has no version'); $bar_meta->superclasses('Foo'); # check with MyMetaClass { package Baz; use metaclass 'MyMetaClass'; } my $baz_meta = Baz->meta; isa_ok($baz_meta, 'Class::MOP::Class'); isa_ok($baz_meta, 'MyMetaClass'); is($my_meta->new_object('package' => 'Baz'), $baz_meta, '... got the right Baz->meta singleton'); is($my_meta->clone_object($baz_meta), $baz_meta, '... cloning got the right Baz->meta singleton'); $baz_meta->superclasses('Bar'); # now create a regular objects for real my $foo = $foo_meta->new_object(); isa_ok($foo, 'Foo'); my $bar = $bar_meta->new_object(); isa_ok($bar, 'Bar'); isa_ok($bar, 'Foo'); my $baz = $baz_meta->new_object(); isa_ok($baz, 'Baz'); isa_ok($baz, 'Bar'); isa_ok($baz, 'Foo'); my $cloned_foo = $foo_meta->clone_object($foo); isa_ok($cloned_foo, 'Foo'); isnt($cloned_foo, $foo, '... $cloned_foo is a new object different from $foo'); # check some errors isnt( exception { $foo_meta->clone_object($meta); }, undef, '... this dies as expected' ); # test stuff { package FooBar; use metaclass; FooBar->meta->add_attribute('test'); } my $attr = FooBar->meta->get_attribute('test'); isa_ok($attr, 'Class::MOP::Attribute'); my $attr_clone = $attr->clone(); isa_ok($attr_clone, 'Class::MOP::Attribute'); isnt($attr, $attr_clone, '... we successfully cloned our attributes'); is($attr->associated_class, $attr_clone->associated_class, '... we successfully did not clone our associated metaclass'); done_testing; rebless_with_extra_params.t100644000767000024 506712200352345 21173 0ustar00etherstaff000000000000Moose-2.1005/t/cmopuse strict; use warnings; use Test::More; use Test::Fatal; use Class::MOP; { package Foo; use metaclass; Foo->meta->add_attribute('bar' => (reader => 'bar')); sub new { (shift)->meta->new_object(@_) } package Bar; use metaclass; use base 'Foo'; Bar->meta->add_attribute('baz' => (reader => 'baz', default => 'BAZ')); } # normal ... { my $foo = Foo->new(bar => 'BAR'); isa_ok($foo, 'Foo'); is($foo->bar, 'BAR', '... got the expect value'); ok(!$foo->can('baz'), '... no baz method though'); is( exception { Bar->meta->rebless_instance($foo) }, undef, '... this works' ); is($foo->bar, 'BAR', '... got the expect value'); ok($foo->can('baz'), '... we have baz method now'); is($foo->baz, 'BAZ', '... got the expect value'); is( exception { Foo->meta->rebless_instance_back($foo) }, undef, '... this works' ); is($foo->bar, 'BAR', '... got the expect value'); ok(!$foo->can('baz'), '... no baz method though'); } # with extra params ... { my $foo = Foo->new(bar => 'BAR'); isa_ok($foo, 'Foo'); is($foo->bar, 'BAR', '... got the expect value'); ok(!$foo->can('baz'), '... no baz method though'); is( exception { Bar->meta->rebless_instance($foo, (baz => 'FOO-BAZ')) }, undef, '... this works' ); is($foo->bar, 'BAR', '... got the expect value'); ok($foo->can('baz'), '... we have baz method now'); is($foo->baz, 'FOO-BAZ', '... got the expect value'); is( exception { Foo->meta->rebless_instance_back($foo) }, undef, '... this works' ); is($foo->bar, 'BAR', '... got the expect value'); ok(!$foo->can('baz'), '... no baz method though'); ok(!exists($foo->{baz}), '... and the baz attribute was deinitialized'); } # with extra params ... { my $foo = Foo->new(bar => 'BAR'); isa_ok($foo, 'Foo'); is($foo->bar, 'BAR', '... got the expect value'); ok(!$foo->can('baz'), '... no baz method though'); is( exception { Bar->meta->rebless_instance($foo, (bar => 'FOO-BAR', baz => 'FOO-BAZ')) }, undef, '... this works' ); is($foo->bar, 'FOO-BAR', '... got the expect value'); ok($foo->can('baz'), '... we have baz method now'); is($foo->baz, 'FOO-BAZ', '... got the expect value'); is( exception { Foo->meta->rebless_instance_back($foo) }, undef, '... this works' ); is($foo->bar, 'FOO-BAR', '... got the expect value'); ok(!$foo->can('baz'), '... no baz method though'); ok(!exists($foo->{baz}), '... and the baz attribute was deinitialized'); } done_testing; Instance.pm100644000767000024 14112200352345 20544 0ustar00etherstaff000000000000Moose-2.1005/t/cmop/lib/MyMetaClass package MyMetaClass::Instance; use strict; use warnings; use base 'Class::MOP::Instance'; 1; immutable_meta_class.t100644000767000024 55412200352345 21102 0ustar00etherstaff000000000000Moose-2.1005/t/immutable#!/usr/bin/perl use strict; use warnings; use Test::More; use Test::Fatal; { package My::Meta; use Moose; extends 'Moose::Meta::Class'; has 'meta_size' => ( is => 'rw', isa => 'Int', ); } is( exception { My::Meta->meta()->make_immutable(debug => 0) }, undef, '... can make a meta class immutable' ); done_testing; custom_error_class.t100644000767000024 431212200352345 21201 0ustar00etherstaff000000000000Moose-2.1005/t/metaclassesuse strict; use warnings; use Test::More; use Test::Requires { 'Test::Output' => '0.01', }; { package My::Exception; use Moose; has error => ( is => 'ro', isa => 'Str', required => 1, ); has [qw( line file package )] => ( is => 'ro', required => 1, ); sub throw { my ($self) = @_; die $self; } } { package My::Error; use base qw( Moose::Error::Default ); sub new { my ( $self, @args ) = @_; $self->create_error_exception(@args)->throw; } sub create_error_exception { my ( $self, %params ) = @_; my $exception = My::Exception->new( error => $params{message}, line => $params{line}, file => $params{file}, package => $params{pack}, ); return $exception; } } { package My::Class; use Moose; __PACKAGE__->meta->error_class("My::Error"); has 'test1' => ( is => 'rw', required => 1, ); ::stderr_is( sub { __PACKAGE__->meta->make_immutable }, q{}, 'no warnings when calling make_immutable with a custom error class' ); } { package My::ClassMutable; use Moose; __PACKAGE__->meta->error_class("My::Error"); has 'test1' => ( is => 'rw', required => 1, ); } { eval { package My::Test; # line 42 My::Class->new; }; my $error = $@; isa_ok( $error, 'My::Exception', 'got exception object (immutable class)' ); is( $error->error, 'Attribute (test1) is required', 'got the right message (immutable class)' ); is( $error->package, 'My::Test', 'got the right package (immutable class)' ); is( $error->line, 42, 'got the right line (immutable class)' ); } { eval { package My::TestMutable; # line 42 My::ClassMutable->new; }; my $error = $@; isa_ok( $error, 'My::Exception', 'got exception object (mutable class)' ); is( $error->error, 'Attribute (test1) is required', 'got the right message (mutable class)' ); } done_testing; remove_attribute.t100644000767000024 162112200352345 21221 0ustar00etherstaff000000000000Moose-2.1005/t/native_traits#!/usr/bin/perl use strict; use warnings; use Test::More; use Test::Fatal; { package MyHomePage; use Moose; has 'counter' => ( traits => ['Counter'], is => 'ro', isa => 'Int', default => 0, handles => { inc_counter => 'inc', dec_counter => 'dec', reset_counter => 'reset', } ); } my $page = MyHomePage->new(); isa_ok( $page, 'MyHomePage' ); can_ok( $page, $_ ) for qw[ counter dec_counter inc_counter reset_counter ]; is( exception { $page->meta->remove_attribute('counter'); }, undef, '... removed the counter attribute okay' ); ok( !$page->meta->has_attribute('counter'), '... no longer has the attribute' ); ok( !$page->can($_), "... our class no longer has the $_ method" ) for qw[ counter dec_counter inc_counter reset_counter ]; done_testing; imported_required_method.t100644000767000024 240412200352345 21174 0ustar00etherstaff000000000000Moose-2.1005/t/roles#!/usr/bin/env perl use strict; use warnings; use Test::More; use Test::Fatal; use Test::Moose; BEGIN { package ExportsFoo; use Sub::Exporter -setup => { exports => ['foo'], }; sub foo { 'FOO' } $INC{'ExportsFoo.pm'} = 1; } { package Foo; use Moose::Role; requires 'foo'; } { package Bar; use Moose::Role; requires 'bar'; } { package Class; use Moose; use ExportsFoo 'foo'; # The grossness near the end of the regex works around a bug with \Q not # escaping \& properly with perl 5.8.x ::like( ::exception { with 'Foo' }, qr/^\Q'Foo' requires the method 'foo' to be implemented by 'Class'. If you imported functions intending to use them as methods, you need to explicitly mark them as such, via Class->meta->add_method(foo => \E\\\&foo\)/, "imported 'method' isn't seen" ); Class->meta->add_method(foo => \&foo); ::is( ::exception { with 'Foo' }, undef, "now it's a method" ); ::like( ::exception { with 'Bar' }, qr/^\Q'Bar' requires the method 'bar' to be implemented by 'Class' at/, "requirement isn't imported, so don't give the extra info in the error" ); } does_ok('Class', 'Foo'); done_testing; role_composite_exclusion.t100644000767000024 522012200352345 21224 0ustar00etherstaff000000000000Moose-2.1005/t/roles#!/usr/bin/perl use strict; use warnings; use Test::More; use Test::Fatal; use Moose::Meta::Role::Application::RoleSummation; use Moose::Meta::Role::Composite; { package Role::Foo; use Moose::Role; package Role::Bar; use Moose::Role; package Role::ExcludesFoo; use Moose::Role; excludes 'Role::Foo'; package Role::DoesExcludesFoo; use Moose::Role; with 'Role::ExcludesFoo'; package Role::DoesFoo; use Moose::Role; with 'Role::Foo'; } ok(Role::ExcludesFoo->meta->excludes_role('Role::Foo'), '... got the right exclusions'); ok(Role::DoesExcludesFoo->meta->excludes_role('Role::Foo'), '... got the right exclusions'); # test simple exclusion isnt( exception { Moose::Meta::Role::Application::RoleSummation->new->apply( Moose::Meta::Role::Composite->new( roles => [ Role::Foo->meta, Role::ExcludesFoo->meta, ] ) ); }, undef, '... this fails as expected' ); # test no conflicts { my $c = Moose::Meta::Role::Composite->new( roles => [ Role::Foo->meta, Role::Bar->meta, ] ); isa_ok($c, 'Moose::Meta::Role::Composite'); is($c->name, 'Role::Foo|Role::Bar', '... got the composite role name'); is( exception { Moose::Meta::Role::Application::RoleSummation->new->apply($c); }, undef, '... this lives as expected' ); } # test no conflicts w/exclusion { my $c = Moose::Meta::Role::Composite->new( roles => [ Role::Bar->meta, Role::ExcludesFoo->meta, ] ); isa_ok($c, 'Moose::Meta::Role::Composite'); is($c->name, 'Role::Bar|Role::ExcludesFoo', '... got the composite role name'); is( exception { Moose::Meta::Role::Application::RoleSummation->new->apply($c); }, undef, '... this lives as expected' ); is_deeply([$c->get_excluded_roles_list], ['Role::Foo'], '... has excluded roles'); } # test conflict with an "inherited" exclusion isnt( exception { Moose::Meta::Role::Application::RoleSummation->new->apply( Moose::Meta::Role::Composite->new( roles => [ Role::Foo->meta, Role::DoesExcludesFoo->meta, ] ) ); }, undef, '... this fails as expected' ); # test conflict with an "inherited" exclusion of an "inherited" role isnt( exception { Moose::Meta::Role::Application::RoleSummation->new->apply( Moose::Meta::Role::Composite->new( roles => [ Role::DoesFoo->meta, Role::DoesExcludesFoo->meta, ] ) ); }, undef, '... this fails as expected' ); done_testing; role_composition_methods.t100644000767000024 664212200352345 21230 0ustar00etherstaff000000000000Moose-2.1005/t/roles#!/usr/bin/perl use strict; use warnings; use Test::More; use Test::Fatal; use Moose::Meta::Role::Application::RoleSummation; use Moose::Meta::Role::Composite; { package Role::Foo; use Moose::Role; sub foo { 'Role::Foo::foo' } package Role::Bar; use Moose::Role; sub bar { 'Role::Bar::bar' } package Role::FooConflict; use Moose::Role; sub foo { 'Role::FooConflict::foo' } package Role::BarConflict; use Moose::Role; sub bar { 'Role::BarConflict::bar' } package Role::AnotherFooConflict; use Moose::Role; with 'Role::FooConflict'; sub baz { 'Role::AnotherFooConflict::baz' } } # test simple attributes { my $c = Moose::Meta::Role::Composite->new( roles => [ Role::Foo->meta, Role::Bar->meta, ] ); isa_ok($c, 'Moose::Meta::Role::Composite'); is($c->name, 'Role::Foo|Role::Bar', '... got the composite role name'); is( exception { Moose::Meta::Role::Application::RoleSummation->new->apply($c); }, undef, '... this succeeds as expected' ); is_deeply( [ sort $c->get_method_list ], [ 'bar', 'foo' ], '... got the right list of methods' ); } # test simple conflict { my $c = Moose::Meta::Role::Composite->new( roles => [ Role::Foo->meta, Role::FooConflict->meta, ] ); isa_ok($c, 'Moose::Meta::Role::Composite'); is($c->name, 'Role::Foo|Role::FooConflict', '... got the composite role name'); is( exception { Moose::Meta::Role::Application::RoleSummation->new->apply($c); }, undef, '... this succeeds as expected' ); is_deeply( [ sort $c->get_method_list ], [], '... got the right list of methods' ); is_deeply( [ sort $c->get_required_method_list ], [ 'foo' ], '... got the right list of required methods' ); } # test complex conflict { my $c = Moose::Meta::Role::Composite->new( roles => [ Role::Foo->meta, Role::Bar->meta, Role::FooConflict->meta, Role::BarConflict->meta, ] ); isa_ok($c, 'Moose::Meta::Role::Composite'); is($c->name, 'Role::Foo|Role::Bar|Role::FooConflict|Role::BarConflict', '... got the composite role name'); is( exception { Moose::Meta::Role::Application::RoleSummation->new->apply($c); }, undef, '... this succeeds as expected' ); is_deeply( [ sort $c->get_method_list ], [], '... got the right list of methods' ); is_deeply( [ sort $c->get_required_method_list ], [ 'bar', 'foo' ], '... got the right list of required methods' ); } # test simple conflict { my $c = Moose::Meta::Role::Composite->new( roles => [ Role::Foo->meta, Role::AnotherFooConflict->meta, ] ); isa_ok($c, 'Moose::Meta::Role::Composite'); is($c->name, 'Role::Foo|Role::AnotherFooConflict', '... got the composite role name'); is( exception { Moose::Meta::Role::Application::RoleSummation->new->apply($c); }, undef, '... this succeeds as expected' ); is_deeply( [ sort $c->get_method_list ], [ 'baz' ], '... got the right list of methods' ); is_deeply( [ sort $c->get_required_method_list ], [ 'foo' ], '... got the right list of required methods' ); } done_testing; role_conflict_edge_cases.t100644000767000024 1212612200352345 21117 0ustar00etherstaff000000000000Moose-2.1005/t/roles#!/usr/bin/perl use strict; use warnings; use Test::More; use Test::Fatal; =pod Check for repeated inheritance causing a method conflict (which is not really a conflict) =cut { package Role::Base; use Moose::Role; sub foo { 'Role::Base::foo' } package Role::Derived1; use Moose::Role; with 'Role::Base'; package Role::Derived2; use Moose::Role; with 'Role::Base'; package My::Test::Class1; use Moose; ::is( ::exception { with 'Role::Derived1', 'Role::Derived2'; }, undef, '... roles composed okay (no conflicts)' ); } ok(Role::Base->meta->has_method('foo'), '... have the method foo as expected'); ok(Role::Derived1->meta->has_method('foo'), '... have the method foo as expected'); ok(Role::Derived2->meta->has_method('foo'), '... have the method foo as expected'); ok(My::Test::Class1->meta->has_method('foo'), '... have the method foo as expected'); is(My::Test::Class1->foo, 'Role::Base::foo', '... got the right value from method'); =pod Check for repeated inheritance causing a method conflict with method modifiers (which is not really a conflict) =cut { package Role::Base2; use Moose::Role; override 'foo' => sub { super() . ' -> Role::Base::foo' }; package Role::Derived3; use Moose::Role; with 'Role::Base2'; package Role::Derived4; use Moose::Role; with 'Role::Base2'; package My::Test::Class2::Base; use Moose; sub foo { 'My::Test::Class2::Base' } package My::Test::Class2; use Moose; extends 'My::Test::Class2::Base'; ::is( ::exception { with 'Role::Derived3', 'Role::Derived4'; }, undef, '... roles composed okay (no conflicts)' ); } ok(Role::Base2->meta->has_override_method_modifier('foo'), '... have the method foo as expected'); ok(Role::Derived3->meta->has_override_method_modifier('foo'), '... have the method foo as expected'); ok(Role::Derived4->meta->has_override_method_modifier('foo'), '... have the method foo as expected'); ok(My::Test::Class2->meta->has_method('foo'), '... have the method foo as expected'); isa_ok(My::Test::Class2->meta->get_method('foo'), 'Moose::Meta::Method::Overridden'); ok(My::Test::Class2::Base->meta->has_method('foo'), '... have the method foo as expected'); isa_ok(My::Test::Class2::Base->meta->get_method('foo'), 'Class::MOP::Method'); is(My::Test::Class2::Base->foo, 'My::Test::Class2::Base', '... got the right value from method'); is(My::Test::Class2->foo, 'My::Test::Class2::Base -> Role::Base::foo', '... got the right value from method'); =pod Check for repeated inheritance of the same code. There are no conflicts with before/around/after method modifiers. This tests around, but should work the same for before/afters as well =cut { package Role::Base3; use Moose::Role; around 'foo' => sub { 'Role::Base::foo(' . (shift)->() . ')' }; package Role::Derived5; use Moose::Role; with 'Role::Base3'; package Role::Derived6; use Moose::Role; with 'Role::Base3'; package My::Test::Class3::Base; use Moose; sub foo { 'My::Test::Class3::Base' } package My::Test::Class3; use Moose; extends 'My::Test::Class3::Base'; ::is( ::exception { with 'Role::Derived5', 'Role::Derived6'; }, undef, '... roles composed okay (no conflicts)' ); } ok(Role::Base3->meta->has_around_method_modifiers('foo'), '... have the method foo as expected'); ok(Role::Derived5->meta->has_around_method_modifiers('foo'), '... have the method foo as expected'); ok(Role::Derived6->meta->has_around_method_modifiers('foo'), '... have the method foo as expected'); ok(My::Test::Class3->meta->has_method('foo'), '... have the method foo as expected'); isa_ok(My::Test::Class3->meta->get_method('foo'), 'Class::MOP::Method::Wrapped'); ok(My::Test::Class3::Base->meta->has_method('foo'), '... have the method foo as expected'); isa_ok(My::Test::Class3::Base->meta->get_method('foo'), 'Class::MOP::Method'); is(My::Test::Class3::Base->foo, 'My::Test::Class3::Base', '... got the right value from method'); is(My::Test::Class3->foo, 'Role::Base::foo(My::Test::Class3::Base)', '... got the right value from method'); =pod Check for repeated inheritance causing a attr conflict (which is not really a conflict) =cut { package Role::Base4; use Moose::Role; has 'foo' => (is => 'ro', default => 'Role::Base::foo'); package Role::Derived7; use Moose::Role; with 'Role::Base4'; package Role::Derived8; use Moose::Role; with 'Role::Base4'; package My::Test::Class4; use Moose; ::is( ::exception { with 'Role::Derived7', 'Role::Derived8'; }, undef, '... roles composed okay (no conflicts)' ); } ok(Role::Base4->meta->has_attribute('foo'), '... have the attribute foo as expected'); ok(Role::Derived7->meta->has_attribute('foo'), '... have the attribute foo as expected'); ok(Role::Derived8->meta->has_attribute('foo'), '... have the attribute foo as expected'); ok(My::Test::Class4->meta->has_attribute('foo'), '... have the attribute foo as expected'); is(My::Test::Class4->new->foo, 'Role::Base::foo', '... got the right value from method'); done_testing; roles_and_method_cloning.t100644000767000024 401312200352345 21126 0ustar00etherstaff000000000000Moose-2.1005/t/roles#!/usr/bin/perl use strict; use warnings; use Test::More; { package Role::Foo; use Moose::Role; sub foo { (caller(0))[3] } } { package ClassA; use Moose; with 'Role::Foo'; } { my $meth = ClassA->meta->get_method('foo'); ok( $meth, 'ClassA has a foo method' ); isa_ok( $meth, 'Moose::Meta::Method' ); is( $meth->original_method, Role::Foo->meta->get_method('foo'), 'ClassA->foo was cloned from Role::Foo->foo' ); is( $meth->fully_qualified_name, 'ClassA::foo', 'fq name is ClassA::foo' ); is( $meth->original_fully_qualified_name, 'Role::Foo::foo', 'original fq name is Role::Foo::foo' ); } { package Role::Bar; use Moose::Role; with 'Role::Foo'; sub bar { } } { my $meth = Role::Bar->meta->get_method('foo'); ok( $meth, 'Role::Bar has a foo method' ); is( $meth->original_method, Role::Foo->meta->get_method('foo'), 'Role::Bar->foo was cloned from Role::Foo->foo' ); is( $meth->fully_qualified_name, 'Role::Bar::foo', 'fq name is Role::Bar::foo' ); is( $meth->original_fully_qualified_name, 'Role::Foo::foo', 'original fq name is Role::Foo::foo' ); } { package ClassB; use Moose; with 'Role::Bar'; } { my $meth = ClassB->meta->get_method('foo'); ok( $meth, 'ClassB has a foo method' ); is( $meth->original_method, Role::Bar->meta->get_method('foo'), 'ClassA->foo was cloned from Role::Bar->foo' ); is( $meth->original_method->original_method, Role::Foo->meta->get_method('foo'), '... which in turn was cloned from Role::Foo->foo' ); is( $meth->fully_qualified_name, 'ClassB::foo', 'fq name is ClassA::foo' ); is( $meth->original_fully_qualified_name, 'Role::Foo::foo', 'original fq name is Role::Foo::foo' ); } isnt( ClassA->foo, "ClassB::foo", "ClassA::foo is not confused with ClassB::foo"); is( ClassB->foo, 'Role::Foo::foo', 'ClassB::foo knows its name' ); is( ClassA->foo, 'Role::Foo::foo', 'ClassA::foo knows its name' ); done_testing; Constructor.pm100644000767000024 1124012200352345 20724 0ustar00etherstaff000000000000Moose-2.1005/lib/Class/MOP/Method package Class::MOP::Method::Constructor; BEGIN { $Class::MOP::Method::Constructor::AUTHORITY = 'cpan:STEVAN'; } { $Class::MOP::Method::Constructor::VERSION = '2.1005'; } use strict; use warnings; use Carp 'confess'; use Scalar::Util 'blessed', 'weaken'; use Try::Tiny; use base 'Class::MOP::Method::Inlined'; sub new { my $class = shift; my %options = @_; (blessed $options{metaclass} && $options{metaclass}->isa('Class::MOP::Class')) || confess "You must pass a metaclass instance if you want to inline" if $options{is_inline}; ($options{package_name} && $options{name}) || confess "You must supply the package_name and name parameters $Class::MOP::Method::UPGRADE_ERROR_TEXT"; my $self = $class->_new(\%options); # we don't want this creating # a cycle in the code, if not # needed weaken($self->{'associated_metaclass'}); $self->_initialize_body; return $self; } sub _new { my $class = shift; return Class::MOP::Class->initialize($class)->new_object(@_) if $class ne __PACKAGE__; my $params = @_ == 1 ? $_[0] : {@_}; return bless { # inherited from Class::MOP::Method body => $params->{body}, # associated_metaclass => $params->{associated_metaclass}, # overridden package_name => $params->{package_name}, name => $params->{name}, original_method => $params->{original_method}, # inherited from Class::MOP::Generated is_inline => $params->{is_inline} || 0, definition_context => $params->{definition_context}, # inherited from Class::MOP::Inlined _expected_method_class => $params->{_expected_method_class}, # defined in this subclass options => $params->{options} || {}, associated_metaclass => $params->{metaclass}, }, $class; } ## accessors sub options { (shift)->{'options'} } sub associated_metaclass { (shift)->{'associated_metaclass'} } ## method sub _initialize_body { my $self = shift; my $method_name = '_generate_constructor_method'; $method_name .= '_inline' if $self->is_inline; $self->{'body'} = $self->$method_name; } sub _eval_environment { my $self = shift; return $self->associated_metaclass->_eval_environment; } sub _generate_constructor_method { return sub { Class::MOP::Class->initialize(shift)->new_object(@_) } } sub _generate_constructor_method_inline { my $self = shift; my $meta = $self->associated_metaclass; my @source = ( 'sub {', $meta->_inline_new_object, '}', ); warn join("\n", @source) if $self->options->{debug}; my $code = try { $self->_compile_code(\@source); } catch { my $source = join("\n", @source); confess "Could not eval the constructor :\n\n$source\n\nbecause :\n\n$_"; }; return $code; } 1; # ABSTRACT: Method Meta Object for constructors __END__ =pod =head1 NAME Class::MOP::Method::Constructor - Method Meta Object for constructors =head1 VERSION version 2.1005 =head1 SYNOPSIS use Class::MOP::Method::Constructor; my $constructor = Class::MOP::Method::Constructor->new( metaclass => $metaclass, options => { debug => 1, # this is all for now }, ); # calling the constructor ... $constructor->body->execute($metaclass->name, %params); =head1 DESCRIPTION This is a subclass of C which generates constructor methods. =head1 METHODS =over 4 =item B<< Class::MOP::Method::Constructor->new(%options) >> This creates a new constructor object. It accepts a hash reference of options. =over 8 =item * metaclass This should be a L object. It is required. =item * name The method name (without a package name). This is required. =item * package_name The package name for the method. This is required. =item * is_inline This indicates whether or not the constructor should be inlined. This defaults to false. =back =item B<< $metamethod->is_inline >> Returns a boolean indicating whether or not the constructor is inlined. =item B<< $metamethod->associated_metaclass >> This returns the L object for the method. =back =head1 AUTHOR Moose is maintained by the Moose Cabal, along with the help of many contributors. See L and L for details. =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2013 by Infinity Interactive, Inc.. This is free software; you can redistribute it and/or modify it under the same terms as the Perl 5 programming language system itself. =cut Meta000755000767000024 012200352345 16461 5ustar00etherstaff000000000000Moose-2.1005/lib/Moose/CookbookWhyMeta.pod100644000767000024 450212200352345 20704 0ustar00etherstaff000000000000Moose-2.1005/lib/Moose/Cookbook/Metapackage Moose::Cookbook::Meta::WhyMeta; # ABSTRACT: Welcome to the meta world (Why Go Meta?) __END__ =pod =head1 NAME Moose::Cookbook::Meta::WhyMeta - Welcome to the meta world (Why Go Meta?) =head1 VERSION version 2.1005 =head1 SUMMARY You might want to read L if you haven't done so yet. If you've ever thought "Moose is great, but I wish it did X differently", then you've gone meta. The meta recipes demonstrate how to change and extend the way Moose works by extending and overriding how the meta classes (L, L, etc) work. The metaclass API is a set of classes that describe classes, roles, attributes, etc. The metaclass API lets you ask questions about a class, like "what attributes does it have?", or "what roles does the class do?" The metaclass system also lets you make changes to a class, for example by adding new methods or attributes. The interface presented by L (C, C, C) is just a thin layer of syntactic sugar over the underlying metaclass system. By extending and changing how this metaclass system works, you can create your own Moose variant. =head2 Examples Let's say that you want to add additional properties to attributes. Specifically, we want to add a "label" property to each attribute, so we can write C<< My::Class->meta()->get_attribute('size')->label() >>. The first recipe shows how to do this using an attribute trait. You might also want to add additional properties to your metaclass. For example, if you were writing an ORM based on Moose, you could associate a table name with each class via the class's metaclass object, letting you write C<< My::Class->meta()->table_name() >>. =head1 SEE ALSO Many of the MooseX modules on CPAN implement metaclass extensions. A couple good examples include L and L. For a more complex example see L or L. =head1 AUTHOR Moose is maintained by the Moose Cabal, along with the help of many contributors. See L and L for details. =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2013 by Infinity Interactive, Inc.. This is free software; you can redistribute it and/or modify it under the same terms as the Perl 5 programming language system itself. =cut Delegation.pm100644000767000024 1316712200352345 20734 0ustar00etherstaff000000000000Moose-2.1005/lib/Moose/Meta/Method package Moose::Meta::Method::Delegation; BEGIN { $Moose::Meta::Method::Delegation::AUTHORITY = 'cpan:STEVAN'; } { $Moose::Meta::Method::Delegation::VERSION = '2.1005'; } use strict; use warnings; use Carp 'confess'; use Scalar::Util 'blessed', 'weaken'; use base 'Moose::Meta::Method', 'Class::MOP::Method::Generated'; sub new { my $class = shift; my %options = @_; ( exists $options{attribute} ) || confess "You must supply an attribute to construct with"; ( blessed( $options{attribute} ) && $options{attribute}->isa('Moose::Meta::Attribute') ) || confess "You must supply an attribute which is a 'Moose::Meta::Attribute' instance"; ( $options{package_name} && $options{name} ) || confess "You must supply the package_name and name parameters $Class::MOP::Method::UPGRADE_ERROR_TEXT"; ( $options{delegate_to_method} && ( !ref $options{delegate_to_method} ) || ( 'CODE' eq ref $options{delegate_to_method} ) ) || confess 'You must supply a delegate_to_method which is a method name or a CODE reference'; exists $options{curried_arguments} || ( $options{curried_arguments} = [] ); ( $options{curried_arguments} && ( 'ARRAY' eq ref $options{curried_arguments} ) ) || confess 'You must supply a curried_arguments which is an ARRAY reference'; my $self = $class->_new( \%options ); weaken( $self->{'attribute'} ); $self->_initialize_body; return $self; } sub _new { my $class = shift; my $options = @_ == 1 ? $_[0] : {@_}; return bless $options, $class; } sub curried_arguments { (shift)->{'curried_arguments'} } sub associated_attribute { (shift)->{'attribute'} } sub delegate_to_method { (shift)->{'delegate_to_method'} } sub _initialize_body { my $self = shift; my $method_to_call = $self->delegate_to_method; return $self->{body} = $method_to_call if ref $method_to_call; my $accessor = $self->_get_delegate_accessor; my $handle_name = $self->name; # NOTE: we used to do a goto here, but the goto didn't handle # failure correctly (it just returned nothing), so I took that # out. However, the more I thought about it, the less I liked it # doing the goto, and I preferred the act of delegation being # actually represented in the stack trace. - SL # not inlining this, since it won't really speed things up at # all... the only thing that would end up different would be # interpolating in $method_to_call, and a bunch of things in the # error handling that mostly never gets called - doy $self->{body} = sub { my $instance = shift; my $proxy = $instance->$accessor(); my $error = !defined $proxy ? ' is not defined' : ref($proxy) && !blessed($proxy) ? qq{ is not an object (got '$proxy')} : undef; if ($error) { $self->throw_error( "Cannot delegate $handle_name to $method_to_call because " . "the value of " . $self->associated_attribute->name . $error, method_name => $method_to_call, object => $instance ); } unshift @_, @{ $self->curried_arguments }; $proxy->$method_to_call(@_); }; } sub _get_delegate_accessor { my $self = shift; my $attr = $self->associated_attribute; # NOTE: # always use a named method when # possible, if you use the method # ref and there are modifiers on # the accessors then it will not # pick up the modifiers too. Only # the named method will assure that # we also have any modifiers run. # - SL my $accessor = $attr->has_read_method ? $attr->get_read_method : $attr->get_read_method_ref; $accessor = $accessor->body if Scalar::Util::blessed $accessor; return $accessor; } 1; # ABSTRACT: A Moose Method metaclass for delegation methods __END__ =pod =head1 NAME Moose::Meta::Method::Delegation - A Moose Method metaclass for delegation methods =head1 VERSION version 2.1005 =head1 DESCRIPTION This is a subclass of L for delegation methods. =head1 METHODS =over 4 =item B<< Moose::Meta::Method::Delegation->new(%options) >> This creates the delegation methods based on the provided C<%options>. =over 4 =item I This must be an instance of C which this accessor is being generated for. This options is B. =item I The method in the associated attribute's value to which we delegate. This can be either a method name or a code reference. =item I An array reference of arguments that will be prepended to the argument list for any call to the delegating method. =back =item B<< $metamethod->associated_attribute >> Returns the attribute associated with this method. =item B<< $metamethod->curried_arguments >> Return any curried arguments that will be passed to the delegated method. =item B<< $metamethod->delegate_to_method >> Returns the method to which this method delegates, as passed to the constructor. =back =head1 BUGS See L for details on reporting bugs. =head1 AUTHOR Moose is maintained by the Moose Cabal, along with the help of many contributors. See L and L for details. =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2013 by Infinity Interactive, Inc.. This is free software; you can redistribute it and/or modify it under the same terms as the Perl 5 programming language system itself. =cut Destructor.pm100644000767000024 1252712200352345 21016 0ustar00etherstaff000000000000Moose-2.1005/lib/Moose/Meta/Method package Moose::Meta::Method::Destructor; BEGIN { $Moose::Meta::Method::Destructor::AUTHORITY = 'cpan:STEVAN'; } { $Moose::Meta::Method::Destructor::VERSION = '2.1005'; } use strict; use warnings; use Devel::GlobalDestruction (); use Scalar::Util 'blessed', 'weaken'; use Try::Tiny; use base 'Moose::Meta::Method', 'Class::MOP::Method::Inlined'; sub new { my $class = shift; my %options = @_; (ref $options{options} eq 'HASH') || $class->throw_error("You must pass a hash of options", data => $options{options}); ($options{package_name} && $options{name}) || $class->throw_error("You must supply the package_name and name parameters $Class::MOP::Method::UPGRADE_ERROR_TEXT"); my $self = bless { # from our superclass 'body' => undef, 'package_name' => $options{package_name}, 'name' => $options{name}, # ... 'options' => $options{options}, 'definition_context' => $options{definition_context}, 'associated_metaclass' => $options{metaclass}, } => $class; # we don't want this creating # a cycle in the code, if not # needed weaken($self->{'associated_metaclass'}); $self->_initialize_body; return $self; } ## accessors sub options { (shift)->{'options'} } ## method sub is_needed { my $self = shift; my $metaclass = shift; ( blessed $metaclass && $metaclass->isa('Class::MOP::Class') ) || $self->throw_error( "The is_needed method expected a metaclass object as its arugment"); return $metaclass->find_method_by_name("DEMOLISHALL"); } sub initialize_body { Carp::cluck('The initialize_body method has been made private.' . " The public version is deprecated and will be removed in a future release.\n"); shift->_initialize_body; } sub _initialize_body { my $self = shift; # TODO: # the %options should also include a both # a call 'initializer' and call 'SUPER::' # options, which should cover approx 90% # of the possible use cases (even if it # requires some adaption on the part of # the author, after all, nothing is free) my $class = $self->associated_metaclass->name; my @source = ( 'sub {', 'my $self = shift;', 'return ' . $self->_generate_fallback_destructor('$self'), 'if Scalar::Util::blessed($self) ne \'' . $class . '\';', $self->_generate_DEMOLISHALL('$self'), 'return;', '}', ); warn join("\n", @source) if $self->options->{debug}; my $code = try { $self->_compile_code(source => \@source); } catch { my $source = join("\n", @source); $self->throw_error( "Could not eval the destructor :\n\n$source\n\nbecause :\n\n$_", error => $_, data => $source, ); }; $self->{'body'} = $code; } sub _generate_fallback_destructor { my $self = shift; my ($inv) = @_; return $inv . '->Moose::Object::DESTROY(@_)'; } sub _generate_DEMOLISHALL { my $self = shift; my ($inv) = @_; my @methods = $self->associated_metaclass->find_all_methods_by_name('DEMOLISH'); return unless @methods; return ( 'local $?;', 'my $igd = Devel::GlobalDestruction::in_global_destruction;', 'Try::Tiny::try {', (map { $inv . '->' . $_->{class} . '::DEMOLISH($igd);' } @methods), '}', 'Try::Tiny::catch {', 'die $_;', '};', ); } 1; # ABSTRACT: Method Meta Object for destructors __END__ =pod =head1 NAME Moose::Meta::Method::Destructor - Method Meta Object for destructors =head1 VERSION version 2.1005 =head1 DESCRIPTION This class is a subclass of L that provides Moose-specific functionality for inlining destructors. To understand this class, you should read the L documentation as well. =head1 INHERITANCE C is a subclass of L I L. =head1 METHODS =over 4 =item B<< Moose::Meta::Method::Destructor->new(%options) >> This constructs a new object. It accepts the following options: =over 8 =item * package_name The package for the class in which the destructor is being inlined. This option is required. =item * name The name of the destructor method. This option is required. =item * metaclass The metaclass for the class this destructor belongs to. This is optional, as it can be set later by calling C<< $metamethod->attach_to_class >>. =back =item B<< Moose::Meta;:Method::Destructor->is_needed($metaclass) >> Given a L object, this method returns a boolean indicating whether the class needs a destructor. If the class or any of its parents defines a C method, it needs a destructor. =back =head1 BUGS See L for details on reporting bugs. =head1 AUTHOR Moose is maintained by the Moose Cabal, along with the help of many contributors. See L and L for details. =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2013 by Infinity Interactive, Inc.. This is free software; you can redistribute it and/or modify it under the same terms as the Perl 5 programming language system itself. =cut Overridden.pm100644000767000024 534112200352345 20735 0ustar00etherstaff000000000000Moose-2.1005/lib/Moose/Meta/Methodpackage Moose::Meta::Method::Overridden; BEGIN { $Moose::Meta::Method::Overridden::AUTHORITY = 'cpan:STEVAN'; } { $Moose::Meta::Method::Overridden::VERSION = '2.1005'; } use strict; use warnings; use base 'Moose::Meta::Method'; sub new { my ( $class, %args ) = @_; # the package can be overridden by roles # it is really more like body's compilation stash # this is where we need to override the definition of super() so that the # body of the code can call the right overridden version my $super_package = $args{package} || $args{class}->name; my $name = $args{name}; my $super = $args{class}->find_next_method_by_name($name); (defined $super) || $class->throw_error("You cannot override '$name' because it has no super method", data => $name); my $super_body = $super->body; my $method = $args{method}; my $body = sub { local $Moose::SUPER_PACKAGE = $super_package; local @Moose::SUPER_ARGS = @_; local $Moose::SUPER_BODY = $super_body; return $method->(@_); }; # FIXME do we need this make sure this works for next::method? # subname "${super_package}::${name}", $method; # FIXME store additional attrs $class->wrap( $body, package_name => $args{class}->name, name => $name ); } 1; # ABSTRACT: A Moose Method metaclass for overridden methods __END__ =pod =head1 NAME Moose::Meta::Method::Overridden - A Moose Method metaclass for overridden methods =head1 VERSION version 2.1005 =head1 DESCRIPTION This class implements method overriding logic for the L C keyword. The overriding subroutine's parent will be invoked explicitly using the C keyword from the parent class's method definition. =head1 METHODS =over 4 =item B<< Moose::Meta::Method::Overridden->new(%options) >> This constructs a new object. It accepts the following options: =over 8 =item * class The metaclass object for the class in which the override is being declared. This option is required. =item * name The name of the method which we are overriding. This method must exist in one of the class's superclasses. This option is required. =item * method The subroutine reference which implements the overriding. This option is required. =back =back =head1 BUGS See L for details on reporting bugs. =head1 AUTHOR Moose is maintained by the Moose Cabal, along with the help of many contributors. See L and L for details. =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2013 by Infinity Interactive, Inc.. This is free software; you can redistribute it and/or modify it under the same terms as the Perl 5 programming language system itself. =cut attribute_delegation.t100644000767000024 3041612200352345 21375 0ustar00etherstaff000000000000Moose-2.1005/t/attributes#!/usr/bin/perl use strict; use warnings; use Test::More; use Test::Fatal; # ------------------------------------------------------------------- # HASH handles # ------------------------------------------------------------------- # the canonical form of of the 'handles' # option is the hash ref mapping a # method name to the delegated method name { package Foo; use Moose; has 'bar' => (is => 'rw', default => 10); sub baz { 42 } package Bar; use Moose; has 'foo' => ( is => 'rw', default => sub { Foo->new }, handles => { 'foo_bar' => 'bar', foo_baz => 'baz', 'foo_bar_to_20' => [ bar => 20 ], }, ); } my $bar = Bar->new; isa_ok($bar, 'Bar'); ok($bar->foo, '... we have something in bar->foo'); isa_ok($bar->foo, 'Foo'); my $meth = Bar->meta->get_method('foo_bar'); isa_ok($meth, 'Moose::Meta::Method::Delegation'); is($meth->associated_attribute->name, 'foo', 'associated_attribute->name for this method is foo'); is($bar->foo->bar, 10, '... bar->foo->bar returned the right default'); can_ok($bar, 'foo_bar'); is($bar->foo_bar, 10, '... bar->foo_bar delegated correctly'); # change the value ... $bar->foo->bar(30); # and make sure the delegation picks it up is($bar->foo->bar, 30, '... bar->foo->bar returned the right (changed) value'); is($bar->foo_bar, 30, '... bar->foo_bar delegated correctly'); # change the value through the delegation ... $bar->foo_bar(50); # and make sure everyone sees it is($bar->foo->bar, 50, '... bar->foo->bar returned the right (changed) value'); is($bar->foo_bar, 50, '... bar->foo_bar delegated correctly'); # change the object we are delegating too my $foo = Foo->new(bar => 25); isa_ok($foo, 'Foo'); is($foo->bar, 25, '... got the right foo->bar'); is( exception { $bar->foo($foo); }, undef, '... assigned the new Foo to Bar->foo' ); is($bar->foo, $foo, '... assigned bar->foo with the new Foo'); is($bar->foo->bar, 25, '... bar->foo->bar returned the right result'); is($bar->foo_bar, 25, '... and bar->foo_bar delegated correctly again'); # curried handles $bar->foo_bar_to_20; is($bar->foo_bar, 20, '... correctly curried a single argument'); # ------------------------------------------------------------------- # ARRAY handles # ------------------------------------------------------------------- # we also support an array based format # which assumes that the name is the same # on either end { package Engine; use Moose; sub go { 'Engine::go' } sub stop { 'Engine::stop' } package Car; use Moose; has 'engine' => ( is => 'rw', default => sub { Engine->new }, handles => [ 'go', 'stop' ] ); } my $car = Car->new; isa_ok($car, 'Car'); isa_ok($car->engine, 'Engine'); can_ok($car->engine, 'go'); can_ok($car->engine, 'stop'); is($car->engine->go, 'Engine::go', '... got the right value from ->engine->go'); is($car->engine->stop, 'Engine::stop', '... got the right value from ->engine->stop'); can_ok($car, 'go'); can_ok($car, 'stop'); is($car->go, 'Engine::go', '... got the right value from ->go'); is($car->stop, 'Engine::stop', '... got the right value from ->stop'); # ------------------------------------------------------------------- # REGEXP handles # ------------------------------------------------------------------- # and we support regexp delegation { package Baz; use Moose; sub foo { 'Baz::foo' } sub bar { 'Baz::bar' } sub boo { 'Baz::boo' } package Baz::Proxy1; use Moose; has 'baz' => ( is => 'ro', isa => 'Baz', default => sub { Baz->new }, handles => qr/.*/ ); package Baz::Proxy2; use Moose; has 'baz' => ( is => 'ro', isa => 'Baz', default => sub { Baz->new }, handles => qr/.oo/ ); package Baz::Proxy3; use Moose; has 'baz' => ( is => 'ro', isa => 'Baz', default => sub { Baz->new }, handles => qr/b.*/ ); } { my $baz_proxy = Baz::Proxy1->new; isa_ok($baz_proxy, 'Baz::Proxy1'); can_ok($baz_proxy, 'baz'); isa_ok($baz_proxy->baz, 'Baz'); can_ok($baz_proxy, 'foo'); can_ok($baz_proxy, 'bar'); can_ok($baz_proxy, 'boo'); is($baz_proxy->foo, 'Baz::foo', '... got the right proxied return value'); is($baz_proxy->bar, 'Baz::bar', '... got the right proxied return value'); is($baz_proxy->boo, 'Baz::boo', '... got the right proxied return value'); } { my $baz_proxy = Baz::Proxy2->new; isa_ok($baz_proxy, 'Baz::Proxy2'); can_ok($baz_proxy, 'baz'); isa_ok($baz_proxy->baz, 'Baz'); can_ok($baz_proxy, 'foo'); can_ok($baz_proxy, 'boo'); is($baz_proxy->foo, 'Baz::foo', '... got the right proxied return value'); is($baz_proxy->boo, 'Baz::boo', '... got the right proxied return value'); } { my $baz_proxy = Baz::Proxy3->new; isa_ok($baz_proxy, 'Baz::Proxy3'); can_ok($baz_proxy, 'baz'); isa_ok($baz_proxy->baz, 'Baz'); can_ok($baz_proxy, 'bar'); can_ok($baz_proxy, 'boo'); is($baz_proxy->bar, 'Baz::bar', '... got the right proxied return value'); is($baz_proxy->boo, 'Baz::boo', '... got the right proxied return value'); } # ------------------------------------------------------------------- # ROLE handles # ------------------------------------------------------------------- { package Foo::Bar; use Moose::Role; requires 'foo'; requires 'bar'; package Foo::Baz; use Moose; sub foo { 'Foo::Baz::FOO' } sub bar { 'Foo::Baz::BAR' } sub baz { 'Foo::Baz::BAZ' } package Foo::Thing; use Moose; has 'thing' => ( is => 'rw', isa => 'Foo::Baz', handles => 'Foo::Bar', ); package Foo::OtherThing; use Moose; use Moose::Util::TypeConstraints; has 'other_thing' => ( is => 'rw', isa => 'Foo::Baz', handles => Moose::Util::TypeConstraints::find_type_constraint('Foo::Bar'), ); } { my $foo = Foo::Thing->new(thing => Foo::Baz->new); isa_ok($foo, 'Foo::Thing'); isa_ok($foo->thing, 'Foo::Baz'); ok($foo->meta->has_method('foo'), '... we have the method we expect'); ok($foo->meta->has_method('bar'), '... we have the method we expect'); ok(!$foo->meta->has_method('baz'), '... we dont have the method we expect'); is($foo->foo, 'Foo::Baz::FOO', '... got the right value'); is($foo->bar, 'Foo::Baz::BAR', '... got the right value'); is($foo->thing->baz, 'Foo::Baz::BAZ', '... got the right value'); } { my $foo = Foo::OtherThing->new(other_thing => Foo::Baz->new); isa_ok($foo, 'Foo::OtherThing'); isa_ok($foo->other_thing, 'Foo::Baz'); ok($foo->meta->has_method('foo'), '... we have the method we expect'); ok($foo->meta->has_method('bar'), '... we have the method we expect'); ok(!$foo->meta->has_method('baz'), '... we dont have the method we expect'); is($foo->foo, 'Foo::Baz::FOO', '... got the right value'); is($foo->bar, 'Foo::Baz::BAR', '... got the right value'); is($foo->other_thing->baz, 'Foo::Baz::BAZ', '... got the right value'); } # ------------------------------------------------------------------- # AUTOLOAD & handles # ------------------------------------------------------------------- { package Foo::Autoloaded; use Moose; sub AUTOLOAD { my $self = shift; my $name = our $AUTOLOAD; $name =~ s/.*://; # strip fully-qualified portion if (@_) { return $self->{$name} = shift; } else { return $self->{$name}; } } package Bar::Autoloaded; use Moose; has 'foo' => ( is => 'rw', default => sub { Foo::Autoloaded->new }, handles => { 'foo_bar' => 'bar' } ); package Baz::Autoloaded; use Moose; has 'foo' => ( is => 'rw', default => sub { Foo::Autoloaded->new }, handles => ['bar'] ); package Goorch::Autoloaded; use Moose; ::isnt( ::exception { has 'foo' => ( is => 'rw', default => sub { Foo::Autoloaded->new }, handles => qr/bar/ ); }, undef, '... you cannot delegate to AUTOLOADED class with regexp' ); } # check HASH based delegation w/ AUTOLOAD { my $bar = Bar::Autoloaded->new; isa_ok($bar, 'Bar::Autoloaded'); ok($bar->foo, '... we have something in bar->foo'); isa_ok($bar->foo, 'Foo::Autoloaded'); # change the value ... $bar->foo->bar(30); # and make sure the delegation picks it up is($bar->foo->bar, 30, '... bar->foo->bar returned the right (changed) value'); is($bar->foo_bar, 30, '... bar->foo_bar delegated correctly'); # change the value through the delegation ... $bar->foo_bar(50); # and make sure everyone sees it is($bar->foo->bar, 50, '... bar->foo->bar returned the right (changed) value'); is($bar->foo_bar, 50, '... bar->foo_bar delegated correctly'); # change the object we are delegating too my $foo = Foo::Autoloaded->new; isa_ok($foo, 'Foo::Autoloaded'); $foo->bar(25); is($foo->bar, 25, '... got the right foo->bar'); is( exception { $bar->foo($foo); }, undef, '... assigned the new Foo to Bar->foo' ); is($bar->foo, $foo, '... assigned bar->foo with the new Foo'); is($bar->foo->bar, 25, '... bar->foo->bar returned the right result'); is($bar->foo_bar, 25, '... and bar->foo_bar delegated correctly again'); } # check ARRAY based delegation w/ AUTOLOAD { my $baz = Baz::Autoloaded->new; isa_ok($baz, 'Baz::Autoloaded'); ok($baz->foo, '... we have something in baz->foo'); isa_ok($baz->foo, 'Foo::Autoloaded'); # change the value ... $baz->foo->bar(30); # and make sure the delegation picks it up is($baz->foo->bar, 30, '... baz->foo->bar returned the right (changed) value'); is($baz->bar, 30, '... baz->foo_bar delegated correctly'); # change the value through the delegation ... $baz->bar(50); # and make sure everyone sees it is($baz->foo->bar, 50, '... baz->foo->bar returned the right (changed) value'); is($baz->bar, 50, '... baz->foo_bar delegated correctly'); # change the object we are delegating too my $foo = Foo::Autoloaded->new; isa_ok($foo, 'Foo::Autoloaded'); $foo->bar(25); is($foo->bar, 25, '... got the right foo->bar'); is( exception { $baz->foo($foo); }, undef, '... assigned the new Foo to Baz->foo' ); is($baz->foo, $foo, '... assigned baz->foo with the new Foo'); is($baz->foo->bar, 25, '... baz->foo->bar returned the right result'); is($baz->bar, 25, '... and baz->foo_bar delegated correctly again'); } # Check that removing attributes removes their handles methods also. { { package Quux; use Moose; has foo => ( isa => 'Foo', default => sub { Foo->new }, handles => { 'foo_bar' => 'bar' } ); } my $i = Quux->new; ok($i->meta->has_method('foo_bar'), 'handles method foo_bar is present'); $i->meta->remove_attribute('foo'); ok(!$i->meta->has_method('foo_bar'), 'handles method foo_bar is removed'); } # Make sure that a useful error message is thrown when the delegation target is # not an object { my $i = Bar->new(foo => undef); like( exception { $i->foo_bar }, qr/is not defined/, 'useful error from unblessed reference' ); my $j = Bar->new(foo => []); like( exception { $j->foo_bar }, qr/is not an object \(got 'ARRAY/, 'useful error from unblessed reference' ); my $k = Bar->new(foo => "Foo"); is( exception { $k->foo_baz }, undef, "but not for class name" ); } { package Delegator; use Moose; sub full { 1 } sub stub; ::like( ::exception{ has d1 => ( isa => 'X', handles => ['full'], ); }, qr/\QYou cannot overwrite a locally defined method (full) with a delegation/, 'got an error when trying to declare a delegation method that overwrites a local method' ); ::is( ::exception{ has d2 => ( isa => 'X', handles => ['stub'], ); }, undef, 'no error when trying to declare a delegation method that overwrites a stub method' ); } done_testing; misc_attribute_tests.t100644000767000024 1572612200352345 21446 0ustar00etherstaff000000000000Moose-2.1005/t/attributes#!/usr/bin/perl use strict; use warnings; use Test::More; use Test::Fatal; { { package Test::Attribute::Inline::Documentation; use Moose; has 'foo' => ( documentation => q{ The 'foo' attribute is my favorite attribute in the whole wide world. }, is => 'bare', ); } my $foo_attr = Test::Attribute::Inline::Documentation->meta->get_attribute('foo'); ok($foo_attr->has_documentation, '... the foo has docs'); is($foo_attr->documentation, q{ The 'foo' attribute is my favorite attribute in the whole wide world. }, '... got the foo docs'); } { { package Test::For::Lazy::TypeConstraint; use Moose; use Moose::Util::TypeConstraints; has 'bad_lazy_attr' => ( is => 'rw', isa => 'ArrayRef', lazy => 1, default => sub { "test" }, ); has 'good_lazy_attr' => ( is => 'rw', isa => 'ArrayRef', lazy => 1, default => sub { [] }, ); } my $test = Test::For::Lazy::TypeConstraint->new; isa_ok($test, 'Test::For::Lazy::TypeConstraint'); isnt( exception { $test->bad_lazy_attr; }, undef, '... this does not work' ); is( exception { $test->good_lazy_attr; }, undef, '... this does not work' ); } { { package Test::Arrayref::Attributes; use Moose; has [qw(foo bar baz)] => ( is => 'rw', ); } my $test = Test::Arrayref::Attributes->new; isa_ok($test, 'Test::Arrayref::Attributes'); can_ok($test, qw(foo bar baz)); } { { package Test::Arrayref::RoleAttributes::Role; use Moose::Role; has [qw(foo bar baz)] => ( is => 'rw', ); } { package Test::Arrayref::RoleAttributes; use Moose; with 'Test::Arrayref::RoleAttributes::Role'; } my $test = Test::Arrayref::RoleAttributes->new; isa_ok($test, 'Test::Arrayref::RoleAttributes'); can_ok($test, qw(foo bar baz)); } { { package Test::UndefDefault::Attributes; use Moose; has 'foo' => ( is => 'ro', isa => 'Str', default => sub { return } ); } isnt( exception { Test::UndefDefault::Attributes->new; }, undef, '... default must return a value which passes the type constraint' ); } { { package OverloadedStr; use Moose; use overload '""' => sub { 'this is *not* a string' }; has 'a_str' => ( isa => 'Str' , is => 'rw' ); } my $moose_obj = OverloadedStr->new; is($moose_obj->a_str( 'foobar' ), 'foobar', 'setter took string'); ok($moose_obj, 'this is a *not* a string'); like( exception { $moose_obj->a_str( $moose_obj ) }, qr/Attribute \(a_str\) does not pass the type constraint because\: Validation failed for 'Str' with value .*OverloadedStr/, '... dies without overloading the string' ); } { { package OverloadBreaker; use Moose; has 'a_num' => ( isa => 'Int' , is => 'rw', default => 7.5 ); } like( exception { OverloadBreaker->new; }, qr/Attribute \(a_num\) does not pass the type constraint because\: Validation failed for 'Int' with value 7\.5/, '... this doesnt trip overload to break anymore ' ); is( exception { OverloadBreaker->new(a_num => 5); }, undef, '... this works fine though' ); } { { package Test::Builder::Attribute; use Moose; has 'foo' => ( required => 1, builder => 'build_foo', is => 'ro'); sub build_foo { return "works" }; } my $meta = Test::Builder::Attribute->meta; my $foo_attr = $meta->get_attribute("foo"); ok($foo_attr->is_required, "foo is required"); ok($foo_attr->has_builder, "foo has builder"); is($foo_attr->builder, "build_foo", ".. and it's named build_foo"); my $instance = Test::Builder::Attribute->new; is($instance->foo, 'works', "foo builder works"); } { { package Test::Builder::Attribute::Broken; use Moose; has 'foo' => ( required => 1, builder => 'build_foo', is => 'ro'); } isnt( exception { Test::Builder::Attribute::Broken->new; }, undef, '... no builder, wtf' ); } { { package Test::LazyBuild::Attribute; use Moose; has 'foo' => ( lazy_build => 1, is => 'ro'); has '_foo' => ( lazy_build => 1, is => 'ro'); has 'fool' => ( lazy_build => 1, is => 'ro'); sub _build_foo { return "works" }; sub _build__foo { return "works too" }; } my $meta = Test::LazyBuild::Attribute->meta; my $foo_attr = $meta->get_attribute("foo"); my $_foo_attr = $meta->get_attribute("_foo"); ok($foo_attr->is_lazy, "foo is lazy"); ok($foo_attr->is_lazy_build, "foo is lazy_build"); ok($foo_attr->has_clearer, "foo has clearer"); is($foo_attr->clearer, "clear_foo", ".. and it's named clear_foo"); ok($foo_attr->has_builder, "foo has builder"); is($foo_attr->builder, "_build_foo", ".. and it's named build_foo"); ok($foo_attr->has_predicate, "foo has predicate"); is($foo_attr->predicate, "has_foo", ".. and it's named has_foo"); ok($_foo_attr->is_lazy, "_foo is lazy"); ok(!$_foo_attr->is_required, "lazy_build attributes are no longer automatically required"); ok($_foo_attr->is_lazy_build, "_foo is lazy_build"); ok($_foo_attr->has_clearer, "_foo has clearer"); is($_foo_attr->clearer, "_clear_foo", ".. and it's named _clear_foo"); ok($_foo_attr->has_builder, "_foo has builder"); is($_foo_attr->builder, "_build__foo", ".. and it's named _build_foo"); ok($_foo_attr->has_predicate, "_foo has predicate"); is($_foo_attr->predicate, "_has_foo", ".. and it's named _has_foo"); my $instance = Test::LazyBuild::Attribute->new; ok(!$instance->has_foo, "noo foo value yet"); ok(!$instance->_has_foo, "noo _foo value yet"); is($instance->foo, 'works', "foo builder works"); is($instance->_foo, 'works too', "foo builder works too"); like( exception { $instance->fool }, qr/Test::LazyBuild::Attribute does not support builder method \'_build_fool\' for attribute \'fool\'/, "Correct error when a builder method is not present" ); } { package OutOfClassTest; use Moose; } is( exception { OutOfClassTest::has('foo', is => 'bare'); }, undef, 'create attr via direct sub call' ); is( exception { OutOfClassTest->can('has')->('bar', is => 'bare'); }, undef, 'create attr via can' ); ok(OutOfClassTest->meta->get_attribute('foo'), 'attr created from sub call'); ok(OutOfClassTest->meta->get_attribute('bar'), 'attr created from can'); { { package Foo; use Moose; ::like( ::exception { has 'foo' => ( 'ro', isa => 'Str' ) }, qr/^Usage/, 'has throws error with odd number of attribute options' ); } } done_testing; more_attr_delegation.t100644000767000024 1534512200352345 21372 0ustar00etherstaff000000000000Moose-2.1005/t/attributes#!/usr/bin/perl use strict; use warnings; use Test::More; use Test::Fatal; =pod This tests the more complex delegation cases and that they do not fail at compile time. =cut { package ChildASuper; use Moose; sub child_a_super_method { "as" } package ChildA; use Moose; extends "ChildASuper"; sub child_a_method_1 { "a1" } sub child_a_method_2 { Scalar::Util::blessed($_[0]) . " a2" } package ChildASub; use Moose; extends "ChildA"; sub child_a_method_3 { "a3" } package ChildB; use Moose; sub child_b_method_1 { "b1" } sub child_b_method_2 { "b2" } sub child_b_method_3 { "b3" } package ChildC; use Moose; sub child_c_method_1 { "c1" } sub child_c_method_2 { "c2" } sub child_c_method_3_la { "c3" } sub child_c_method_4_la { "c4" } package ChildD; use Moose; sub child_d_method_1 { "d1" } sub child_d_method_2 { "d2" } package ChildE; # no Moose sub new { bless {}, shift } sub child_e_method_1 { "e1" } sub child_e_method_2 { "e2" } package ChildF; # no Moose sub new { bless {}, shift } sub child_f_method_1 { "f1" } sub child_f_method_2 { "f2" } package ChildG; use Moose; sub child_g_method_1 { "g1" } package ChildH; use Moose; sub child_h_method_1 { "h1" } sub parent_method_1 { "child_parent_1" } package ChildI; use Moose; sub child_i_method_1 { "i1" } sub parent_method_1 { "child_parent_1" } package Parent; use Moose; sub parent_method_1 { "parent_1" } ::can_ok('Parent', 'parent_method_1'); ::isnt( ::exception { has child_a => ( is => "ro", default => sub { ChildA->new }, handles => qr/.*/, ); }, undef, "all_methods requires explicit isa" ); ::is( ::exception { has child_a => ( isa => "ChildA", is => "ro", default => sub { ChildA->new }, handles => qr/.*/, ); }, undef, "allow all_methods with explicit isa" ); ::is( ::exception { has child_b => ( is => 'ro', default => sub { ChildB->new }, handles => [qw/child_b_method_1/], ); }, undef, "don't need to declare isa if method list is predefined" ); ::is( ::exception { has child_c => ( isa => "ChildC", is => "ro", default => sub { ChildC->new }, handles => qr/_la$/, ); }, undef, "can declare regex collector" ); ::isnt( ::exception { has child_d => ( is => "ro", default => sub { ChildD->new }, handles => sub { my ( $class, $delegate_class ) = @_; } ); }, undef, "can't create attr with generative handles parameter and no isa" ); ::is( ::exception { has child_d => ( isa => "ChildD", is => "ro", default => sub { ChildD->new }, handles => sub { my ( $class, $delegate_class ) = @_; return; } ); }, undef, "can't create attr with generative handles parameter and no isa" ); ::is( ::exception { has child_e => ( isa => "ChildE", is => "ro", default => sub { ChildE->new }, handles => ["child_e_method_2"], ); }, undef, "can delegate to non moose class using explicit method list" ); my $delegate_class; ::is( ::exception { has child_f => ( isa => "ChildF", is => "ro", default => sub { ChildF->new }, handles => sub { $delegate_class = $_[1]->name; return; }, ); }, undef, "subrefs on non moose class give no meta" ); ::is( $delegate_class, "ChildF", "plain classes are handed down to subs" ); ::is( ::exception { has child_g => ( isa => "ChildG", default => sub { ChildG->new }, handles => ["child_g_method_1"], ); }, undef, "can delegate to object even without explicit reader" ); ::can_ok('Parent', 'parent_method_1'); ::isnt( ::exception { has child_h => ( isa => "ChildH", is => "ro", default => sub { ChildH->new }, handles => sub { map { $_, $_ } $_[1]->get_all_method_names }, ); }, undef, "Can't override exisiting class method in delegate" ); ::can_ok('Parent', 'parent_method_1'); ::is( ::exception { has child_i => ( isa => "ChildI", is => "ro", default => sub { ChildI->new }, handles => sub { map { $_, $_ } grep { !/^parent_method_1|meta$/ } $_[1]->get_all_method_names; }, ); }, undef, "Test handles code ref for skipping predefined methods" ); sub parent_method { "p" } } # sanity isa_ok( my $p = Parent->new, "Parent" ); isa_ok( $p->child_a, "ChildA" ); isa_ok( $p->child_b, "ChildB" ); isa_ok( $p->child_c, "ChildC" ); isa_ok( $p->child_d, "ChildD" ); isa_ok( $p->child_e, "ChildE" ); isa_ok( $p->child_f, "ChildF" ); isa_ok( $p->child_i, "ChildI" ); ok(!$p->can('child_g'), '... no child_g accessor defined'); ok(!$p->can('child_h'), '... no child_h accessor defined'); is( $p->parent_method, "p", "parent method" ); is( $p->child_a->child_a_super_method, "as", "child supermethod" ); is( $p->child_a->child_a_method_1, "a1", "child method" ); can_ok( $p, "child_a_super_method" ); can_ok( $p, "child_a_method_1" ); can_ok( $p, "child_a_method_2" ); ok( !$p->can( "child_a_method_3" ), "but not subclass of delegate class" ); is( $p->child_a_method_1, $p->child_a->child_a_method_1, "delegate behaves the same" ); is( $p->child_a_method_2, "ChildA a2", "delegates are their own invocants" ); can_ok( $p, "child_b_method_1" ); ok( !$p->can("child_b_method_2"), "but not ChildB's unspecified siblings" ); ok( !$p->can($_), "none of ChildD's methods ($_)" ) for grep { /^child/ } map { $_->name } ChildD->meta->get_all_methods(); can_ok( $p, "child_c_method_3_la" ); can_ok( $p, "child_c_method_4_la" ); is( $p->child_c_method_3_la, "c3", "ChildC method delegated OK" ); can_ok( $p, "child_e_method_2" ); ok( !$p->can("child_e_method_1"), "but not child_e_method_1"); is( $p->child_e_method_2, "e2", "delegate to non moose class (child_e_method_2)" ); can_ok( $p, "child_g_method_1" ); is( $p->child_g_method_1, "g1", "delegate to moose class without reader (child_g_method_1)" ); can_ok( $p, "child_i_method_1" ); is( $p->parent_method_1, "parent_1", "delegate doesn't override existing method" ); done_testing; non_alpha_attr_names.t100644000767000024 271112200352345 21330 0ustar00etherstaff000000000000Moose-2.1005/t/attributesuse strict; use warnings; use Test::More; use Test::Moose; { package Foo; use Moose; has 'type' => ( required => 0, reader => 'get_type', default => 1, ); # Assigning types to these non-alpha attrs exposed a bug in Moose. has '@type' => ( isa => 'Str', required => 0, reader => 'get_at_type', writer => 'set_at_type', default => 'at type', ); has 'has spaces' => ( isa => 'Int', required => 0, reader => 'get_hs', default => 42, ); has '!req' => ( required => 1, reader => 'req' ); no Moose; } with_immutable { ok( Foo->meta->has_attribute($_), "Foo has '$_' attribute" ) for 'type', '@type', 'has spaces'; my $foo = Foo->new( '!req' => 42 ); is( $foo->get_type, 1, q{'type' attribute default is 1} ); is( $foo->get_at_type, 'at type', q{'@type' attribute default is 1} ); is( $foo->get_hs, 42, q{'has spaces' attribute default is 42} ); $foo = Foo->new( type => 'foo', '@type' => 'bar', 'has spaces' => 200, '!req' => 84, ); isa_ok( $foo, 'Foo' ); is( $foo->get_at_type, 'bar', q{reader for '@type'} ); is( $foo->get_hs, 200, q{reader for 'has spaces'} ); $foo->set_at_type(99); is( $foo->get_at_type, 99, q{writer for '@type' worked} ); } 'Foo'; done_testing; attribute_trait_parameters.t100644000767000024 166612200352345 21367 0ustar00etherstaff000000000000Moose-2.1005/t/bugsuse strict; use warnings; use Test::More; use Test::Requires { 'Test::Output' => '0.01', # skip all if not installed }; { package R; use Moose::Role; sub method { } } { package C; use Moose; ::stderr_is{ has attr => ( is => 'ro', traits => [ R => { ignored => 1 }, ], ); } q{}, 'no warning with foreign parameterized attribute traits'; ::stderr_is{ has alias_attr => ( is => 'ro', traits => [ R => { -alias => { method => 'new_name' } }, ], ); } q{}, 'no warning with -alias parameterized attribute traits'; ::stderr_is{ has excludes_attr => ( is => 'ro', traits => [ R => { -excludes => ['method'] }, ], ); } q{}, 'no warning with -excludes parameterized attribute traits'; } done_testing; AttributesWithHistory_test.t100644000767000024 506212200352345 21331 0ustar00etherstaff000000000000Moose-2.1005/t/cmopuse strict; use warnings; use Test::More; use File::Spec; use Class::MOP; BEGIN { require_ok(File::Spec->catfile('examples', 'AttributesWithHistory.pod')); } { package Foo; use metaclass; Foo->meta->add_attribute(AttributesWithHistory->new('foo' => ( accessor => 'foo', history_accessor => 'get_foo_history', ))); Foo->meta->add_attribute(AttributesWithHistory->new('bar' => ( reader => 'get_bar', writer => 'set_bar', history_accessor => 'get_bar_history', ))); sub new { my $class = shift; $class->meta->new_object(@_); } } my $foo = Foo->new(); isa_ok($foo, 'Foo'); can_ok($foo, 'foo'); can_ok($foo, 'get_foo_history'); can_ok($foo, 'set_bar'); can_ok($foo, 'get_bar'); can_ok($foo, 'get_bar_history'); my $foo2 = Foo->new(); isa_ok($foo2, 'Foo'); is($foo->foo, undef, '... foo is not yet defined'); is_deeply( [ $foo->get_foo_history() ], [ ], '... got correct empty history for foo'); is($foo2->foo, undef, '... foo2 is not yet defined'); is_deeply( [ $foo2->get_foo_history() ], [ ], '... got correct empty history for foo2'); $foo->foo(42); is($foo->foo, 42, '... foo == 42'); is_deeply( [ $foo->get_foo_history() ], [ 42 ], '... got correct history for foo'); is($foo2->foo, undef, '... foo2 is still not yet defined'); is_deeply( [ $foo2->get_foo_history() ], [ ], '... still got correct empty history for foo2'); $foo2->foo(100); is($foo->foo, 42, '... foo is still == 42'); is_deeply( [ $foo->get_foo_history() ], [ 42 ], '... still got correct history for foo'); is($foo2->foo, 100, '... foo2 == 100'); is_deeply( [ $foo2->get_foo_history() ], [ 100 ], '... got correct empty history for foo2'); $foo->foo(43); $foo->foo(44); $foo->foo(45); $foo->foo(46); is_deeply( [ $foo->get_foo_history() ], [ 42, 43, 44, 45, 46 ], '... got correct history for foo'); is($foo->get_bar, undef, '... bar is not yet defined'); is_deeply( [ $foo->get_bar_history() ], [ ], '... got correct empty history for foo'); $foo->set_bar("FOO"); is($foo->get_bar, "FOO", '... bar == "FOO"'); is_deeply( [ $foo->get_bar_history() ], [ "FOO" ], '... got correct history for foo'); $foo->set_bar("BAR"); $foo->set_bar("BAZ"); is_deeply( [ $foo->get_bar_history() ], [ qw/FOO BAR BAZ/ ], '... got correct history for bar'); is_deeply( [ $foo->get_foo_history() ], [ 42, 43, 44, 45, 46 ], '... still have the correct history for foo'); done_testing; C3MethodDispatchOrder_test.t100644000767000024 212612200352345 21045 0ustar00etherstaff000000000000Moose-2.1005/t/cmopuse strict; use warnings; use Test::More; use File::Spec; use Class::MOP; use Test::Requires { 'Algorithm::C3' => '0.01', # skip all if not installed }; BEGIN { require_ok(File::Spec->catfile('examples', 'C3MethodDispatchOrder.pod')); } { package Diamond_A; use metaclass 'C3MethodDispatchOrder'; sub hello { 'Diamond_A::hello' } package Diamond_B; use metaclass 'C3MethodDispatchOrder'; __PACKAGE__->meta->superclasses('Diamond_A'); package Diamond_C; use metaclass 'C3MethodDispatchOrder'; __PACKAGE__->meta->superclasses('Diamond_A'); sub hello { 'Diamond_C::hello' } package Diamond_D; use metaclass 'C3MethodDispatchOrder'; __PACKAGE__->meta->superclasses('Diamond_B', 'Diamond_C'); } is_deeply( [ Diamond_D->meta->class_precedence_list ], [ qw(Diamond_D Diamond_B Diamond_C Diamond_A) ], '... got the right MRO for Diamond_D'); is(Diamond_D->hello, 'Diamond_C::hello', '... got the right dispatch order'); is(Diamond_D->can('hello')->(), 'Diamond_C::hello', '... can(method) resolved itself as expected'); done_testing; InstanceCountingClass_test.t100644000767000024 226712200352345 21232 0ustar00etherstaff000000000000Moose-2.1005/t/cmopuse strict; use warnings; use Test::More; use File::Spec; use Class::MOP; BEGIN { require_ok(File::Spec->catfile('examples', 'InstanceCountingClass.pod')); } =pod This is a trivial and contrived example of how to make a metaclass which will count all the instances created. It is not meant to be anything more than a simple demonstration of how to make a metaclass. =cut { package Foo; use metaclass 'InstanceCountingClass'; sub new { my $class = shift; $class->meta->new_object(@_); } package Bar; our @ISA = ('Foo'); } is(Foo->meta->get_count(), 0, '... our Foo count is 0'); is(Bar->meta->get_count(), 0, '... our Bar count is 0'); my $foo = Foo->new(); isa_ok($foo, 'Foo'); is(Foo->meta->get_count(), 1, '... our Foo count is now 1'); is(Bar->meta->get_count(), 0, '... our Bar count is still 0'); my $bar = Bar->new(); isa_ok($bar, 'Bar'); is(Foo->meta->get_count(), 1, '... our Foo count is still 1'); is(Bar->meta->get_count(), 1, '... our Bar count is now 1'); for (2 .. 10) { Foo->new(); } is(Foo->meta->get_count(), 10, '... our Foo count is now 10'); is(Bar->meta->get_count(), 1, '... our Bar count is still 1'); done_testing; Attribute.pm100644000767000024 14312200352345 20745 0ustar00etherstaff000000000000Moose-2.1005/t/cmop/lib/MyMetaClass package MyMetaClass::Attribute; use strict; use warnings; use base 'Class::MOP::Attribute'; 1; moose_util_does_role.t100644000767000024 236712200352345 21366 0ustar00etherstaff000000000000Moose-2.1005/t/moose_util#!/usr/bin/perl use strict; use warnings; use Test::More; use Moose::Util ':all'; { package Foo; use Moose::Role; } { package Bar; use Moose; with qw/Foo/; } { package Baz; use Moose; } { package Quux; use metaclass; } { package Foo::Foo; use Moose::Role; with 'Foo'; } { package DoesMethod; use Moose; sub does { my $self = shift; my ($role) = @_; return 1 if $role eq 'Something::Else'; return $self->SUPER::does(@_); } } # Classes ok(does_role('Bar', 'Foo'), '... Bar does Foo'); ok(!does_role('Baz', 'Foo'), '... Baz doesnt do Foo'); # Objects my $bar = Bar->new; ok(does_role($bar, 'Foo'), '... $bar does Foo'); my $baz = Baz->new; ok(!does_role($baz, 'Foo'), '... $baz doesnt do Foo'); # Invalid values ok(!does_role(undef,'Foo'), '... undef doesnt do Foo'); ok(!does_role(1,'Foo'), '... 1 doesnt do Foo'); # non Moose metaclass ok(!does_role('Quux', 'Foo'), '... Quux doesnt do Foo (does not die tho)'); # overriding the does method works properly ok(does_role('DoesMethod', 'Something::Else'), '... can override the does method'); # Self ok(does_role('Foo', 'Foo'), '... Foo does do Foo'); # sub-Roles ok(does_role('Foo::Foo', 'Foo'), '... Foo::Foo does do Foo'); done_testing; role_composition_override.t100644000767000024 514412200352345 21400 0ustar00etherstaff000000000000Moose-2.1005/t/roles#!/usr/bin/perl use strict; use warnings; use Test::More; use Test::Fatal; use Moose::Meta::Role::Application::RoleSummation; use Moose::Meta::Role::Composite; { package Role::Foo; use Moose::Role; override foo => sub { 'Role::Foo::foo' }; package Role::Bar; use Moose::Role; override bar => sub { 'Role::Bar::bar' }; package Role::FooConflict; use Moose::Role; override foo => sub { 'Role::FooConflict::foo' }; package Role::FooMethodConflict; use Moose::Role; sub foo { 'Role::FooConflict::foo' } package Role::BarMethodConflict; use Moose::Role; sub bar { 'Role::BarConflict::bar' } } # test simple overrides { my $c = Moose::Meta::Role::Composite->new( roles => [ Role::Foo->meta, Role::Bar->meta, ] ); isa_ok($c, 'Moose::Meta::Role::Composite'); is($c->name, 'Role::Foo|Role::Bar', '... got the composite role name'); is( exception { Moose::Meta::Role::Application::RoleSummation->new->apply($c); }, undef, '... this lives ok' ); is_deeply( [ sort $c->get_method_modifier_list('override') ], [ 'bar', 'foo' ], '... got the right list of methods' ); } # test simple overrides w/ conflicts isnt( exception { Moose::Meta::Role::Application::RoleSummation->new->apply( Moose::Meta::Role::Composite->new( roles => [ Role::Foo->meta, Role::FooConflict->meta, ] ) ); }, undef, '... this fails as expected' ); # test simple overrides w/ conflicts isnt( exception { Moose::Meta::Role::Application::RoleSummation->new->apply( Moose::Meta::Role::Composite->new( roles => [ Role::Foo->meta, Role::FooMethodConflict->meta, ] ) ); }, undef, '... this fails as expected' ); # test simple overrides w/ conflicts isnt( exception { Moose::Meta::Role::Application::RoleSummation->new->apply( Moose::Meta::Role::Composite->new( roles => [ Role::Foo->meta, Role::Bar->meta, Role::FooConflict->meta, ] ) ); }, undef, '... this fails as expected' ); # test simple overrides w/ conflicts isnt( exception { Moose::Meta::Role::Application::RoleSummation->new->apply( Moose::Meta::Role::Composite->new( roles => [ Role::Foo->meta, Role::Bar->meta, Role::FooMethodConflict->meta, ] ) ); }, undef, '... this fails as expected' ); done_testing; run_time_role_composition.t100644000767000024 575612200352345 21414 0ustar00etherstaff000000000000Moose-2.1005/t/roles#!/usr/bin/perl use strict; use warnings; use Test::More; use Scalar::Util qw(blessed); =pod This test can be used as a basis for the runtime role composition. Apparently it is not as simple as just making an anon class. One of the problems is the way that anon classes are DESTROY-ed, which is not very compatible with how instances are dealt with. =cut { package Bark; use Moose::Role; sub talk { 'woof' } package Sleeper; use Moose::Role; sub sleep { 'snore' } sub talk { 'zzz' } package My::Class; use Moose; sub sleep { 'nite-nite' } } my $obj = My::Class->new; isa_ok($obj, 'My::Class'); my $obj2 = My::Class->new; isa_ok($obj2, 'My::Class'); { ok(!$obj->can( 'talk' ), "... the role is not composed yet"); ok(!$obj->does('Bark'), '... we do not do any roles yet'); Bark->meta->apply($obj); ok($obj->does('Bark'), '... we now do the Bark role'); ok(!My::Class->does('Bark'), '... the class does not do the Bark role'); isa_ok($obj, 'My::Class'); isnt(blessed($obj), 'My::Class', '... but it is no longer blessed into My::Class'); ok(!My::Class->can('talk'), "... the role is not composed at the class level"); ok($obj->can('talk'), "... the role is now composed at the object level"); is($obj->talk, 'woof', '... got the right return value for the newly composed method'); } { ok(!$obj2->does('Sleeper'), '... we do not do any roles yet'); Sleeper->meta->apply($obj2); ok($obj2->does('Sleeper'), '... we now do the Sleeper role'); isnt(blessed($obj), blessed($obj2), '... they DO NOT share the same anon-class/role thing'); } { is($obj->sleep, 'nite-nite', '... the original method responds as expected'); ok(!$obj->does('Sleeper'), '... we do not do the Sleeper role'); Sleeper->meta->apply($obj); ok($obj->does('Bark'), '... we still do the Bark role'); ok($obj->does('Sleeper'), '... we now do the Sleeper role too'); ok(!My::Class->does('Sleeper'), '... the class does not do the Sleeper role'); isnt(blessed($obj), blessed($obj2), '... they still don\'t share the same anon-class/role thing'); isa_ok($obj, 'My::Class'); is(My::Class->sleep, 'nite-nite', '... the original method still responds as expected'); is($obj->sleep, 'snore', '... got the right return value for the newly composed method'); is($obj->talk, 'zzz', '... got the right return value for the newly composed method'); } { ok(!$obj2->does('Bark'), '... we do not do Bark yet'); Bark->meta->apply($obj2); ok($obj2->does('Bark'), '... we now do the Bark role'); isnt(blessed($obj), blessed($obj2), '... they still don\'t share the same anon-class/role thing'); } # test that anon classes are equivalent after role composition in the same order { foreach ($obj, $obj2) { $_ = My::Class->new; Bark->meta->apply($_); Sleeper->meta->apply($_); } is(blessed($obj), blessed($obj2), '... they now share the same anon-class/role thing'); } done_testing; role_insertion_order.t100644000767000024 162512200352345 21406 0ustar00etherstaff000000000000Moose-2.1005/t/todo_tests#!/usr/bin/env perl use strict; use warnings; use Test::More; { package Foo::Role; use Moose::Role; has 'a' => (is => 'ro'); has 'b' => (is => 'ro'); has 'c' => (is => 'ro'); } { package Foo; use Moose; has 'd' => (is => 'ro'); with 'Foo::Role'; has 'e' => (is => 'ro'); } my %role_insertion_order = ( a => 0, b => 1, c => 2, ); is_deeply({ map { $_->name => $_->insertion_order } map { Foo::Role->meta->get_attribute($_) } Foo::Role->meta->get_attribute_list }, \%role_insertion_order, "right insertion order within the role"); my %class_insertion_order = ( d => 0, a => 1, b => 2, c => 3, e => 4, ); { local $TODO = "insertion order is lost during role application"; is_deeply({ map { $_->name => $_->insertion_order } Foo->meta->get_all_attributes }, \%class_insertion_order, "right insertion order within the class"); } done_testing; class_subtypes.t100644000767000024 623412200352345 21445 0ustar00etherstaff000000000000Moose-2.1005/t/type_constraints#!/usr/bin/perl use strict; use warnings; use Test::More; use Test::Fatal; use Moose::Util::TypeConstraints; use Moose::Meta::TypeConstraint; ## Create a subclass with a custom method { package Test::Moose::Meta::TypeConstraint::AnySubType; use Moose; extends 'Moose::Meta::TypeConstraint'; sub my_custom_method { return 1; } } my $Int = find_type_constraint('Int'); ok $Int, 'Got a good type constraint'; my $parent = Test::Moose::Meta::TypeConstraint::AnySubType->new({ name => "Test::Moose::Meta::TypeConstraint::AnySubType" , parent => $Int, }); ok $parent, 'Created type constraint'; ok $parent->check(1), 'Correctly passed'; ok ! $parent->check('a'), 'correctly failed'; ok $parent->my_custom_method, 'found the custom method'; my $subtype1 = subtype 'another_subtype' => as $parent; ok $subtype1, 'Created type constraint'; ok $subtype1->check(1), 'Correctly passed'; ok ! $subtype1->check('a'), 'correctly failed'; ok $subtype1->my_custom_method, 'found the custom method'; my $subtype2 = subtype 'another_subtype' => as $subtype1 => where { $_ < 10 }; ok $subtype2, 'Created type constraint'; ok $subtype2->check(1), 'Correctly passed'; ok ! $subtype2->check('a'), 'correctly failed'; ok ! $subtype2->check(100), 'correctly failed'; ok $subtype2->my_custom_method, 'found the custom method'; { package Foo; use Moose; } { package Bar; use Moose; extends 'Foo'; } { package Baz; use Moose; } my $foo = class_type 'Foo'; my $isa_foo = subtype 'IsaFoo' => as $foo; ok $isa_foo, 'Created subtype of Foo type'; ok $isa_foo->check( Foo->new ), 'Foo passes check'; ok $isa_foo->check( Bar->new ), 'Bar passes check'; ok ! $isa_foo->check( Baz->new ), 'Baz does not pass check'; like $foo->get_message( Baz->new ), qr/^Validation failed for 'Foo' with value .*Baz.* \(not isa Foo\)/, 'Better validation message'; # Maybe in the future this *should* inherit? like $isa_foo->get_message( Baz->new ), qr/^Validation failed for 'IsaFoo' with value .*Baz.*/, "Subtypes do not automatically inherit parent type's message"; # Implicit types { package Quux; use Moose; has age => ( isa => 'Positive', is => 'bare', ); } like( exception { Quux->new(age => 3) }, qr/^Attribute \(age\) does not pass the type constraint because: Validation failed for 'Positive' with value 3 \(not isa Positive\)/ ); is( exception { Quux->new(age => (bless {}, 'Positive')); }, undef ); eval " package Positive; use Moose; "; like( exception { Quux->new(age => 3) }, qr/^Attribute \(age\) does not pass the type constraint because: Validation failed for 'Positive' with value 3 \(not isa Positive\)/ ); is( exception { Quux->new(age => Positive->new) }, undef ); class_type 'Negative' => message { "$_ is not a Negative Nancy" }; { package Quux::Ier; use Moose; has age => ( isa => 'Negative', is => 'bare', ); } like( exception { Quux::Ier->new(age => 3) }, qr/^Attribute \(age\) does not pass the type constraint because: 3 is not a Negative Nancy / ); is( exception { Quux::Ier->new(age => (bless {}, 'Negative')) }, undef ); done_testing; name_conflicts.t100644000767000024 651312200352345 21366 0ustar00etherstaff000000000000Moose-2.1005/t/type_constraints#!/usr/bin/env perl use strict; use warnings; use Test::More; use Test::Fatal; use Moose::Util::TypeConstraints; { package Types; use Moose::Util::TypeConstraints; type 'Foo1'; subtype 'Foo2', as 'Str'; class_type 'Foo3'; role_type 'Foo4'; { package Foo5; use Moose; } { package Foo6; use Moose::Role; } { package IsaAttr; use Moose; has foo => (is => 'ro', isa => 'Foo7'); } { package DoesAttr; use Moose; has foo => (is => 'ro', does => 'Foo8'); } } { my $anon = 0; my @checks = ( [1, sub { type $_[0] }, 'type'], [1, sub { subtype $_[0], as 'Str' }, 'subtype'], [1, sub { class_type $_[0] }, 'class_type'], [1, sub { role_type $_[0] }, 'role_type'], # should these two die? [0, sub { eval "package $_[0]; use Moose; 1" || die $@ }, 'use Moose'], [0, sub { eval "package $_[0]; use Moose::Role; 1" || die $@ }, 'use Moose::Role'], [0, sub { $anon++; eval < (is => 'ro', isa => '$_[0]'); 1 CLASS }, 'isa => "Thing"'], [0, sub { $anon++; eval < (is => 'ro', does => '$_[0]'); 1 CLASS }, 'does => "Thing"'], ); sub check_conflicts { my ($type_name) = @_; my $type = find_type_constraint($type_name); for my $check (@checks) { my ($should_fail, $code, $desc) = @$check; $should_fail = 0 if overriding_with_equivalent_type($type, $desc); unload_class($type_name); if ($should_fail) { like( exception { $code->($type_name) }, qr/^The type constraint '$type_name' has already been created in [\w:]+ and cannot be created again in [\w:]+/, "trying to override $type_name via '$desc' should die" ); } else { is( exception { $code->($type_name) }, undef, "trying to override $type_name via '$desc' should do nothing" ); } is($type, find_type_constraint($type_name), "type didn't change"); } } sub unload_class { my ($class) = @_; my $meta = Class::MOP::class_of($class); return unless $meta; $meta->add_package_symbol('@ISA', []); $meta->remove_package_symbol('&'.$_) for $meta->list_all_package_symbols('CODE'); undef $meta; Class::MOP::remove_metaclass_by_name($class); } sub overriding_with_equivalent_type { my ($type, $desc) = @_; if ($type->isa('Moose::Meta::TypeConstraint::Class')) { return 1 if $desc eq 'use Moose' || $desc eq 'class_type' || $desc eq 'isa => "Thing"'; } if ($type->isa('Moose::Meta::TypeConstraint::Role')) { return 1 if $desc eq 'use Moose::Role' || $desc eq 'role_type' || $desc eq 'does => "Thing"'; } return; } } { check_conflicts($_) for map { "Foo$_" } 1..8; } done_testing; recipes000755000767000024 012200352345 14072 5ustar00etherstaff000000000000Moose-2.1005/tbasics_company_subtypes.t100644000767000024 2250612200352345 21374 0ustar00etherstaff000000000000Moose-2.1005/t/recipes#!/usr/bin/perl -w use strict; use Test::More 'no_plan'; use Test::Fatal; $| = 1; # =begin testing SETUP use Test::Requires { 'Locale::US' => '0', 'Regexp::Common' => '0', }; # =begin testing SETUP { package Address; use Moose; use Moose::Util::TypeConstraints; use Locale::US; use Regexp::Common 'zip'; my $STATES = Locale::US->new; subtype 'USState' => as Str => where { ( exists $STATES->{code2state}{ uc($_) } || exists $STATES->{state2code}{ uc($_) } ); }; subtype 'USZipCode' => as Value => where { /^$RE{zip}{US}{-extended => 'allow'}$/; }; has 'street' => ( is => 'rw', isa => 'Str' ); has 'city' => ( is => 'rw', isa => 'Str' ); has 'state' => ( is => 'rw', isa => 'USState' ); has 'zip_code' => ( is => 'rw', isa => 'USZipCode' ); package Company; use Moose; use Moose::Util::TypeConstraints; has 'name' => ( is => 'rw', isa => 'Str', required => 1 ); has 'address' => ( is => 'rw', isa => 'Address' ); has 'employees' => ( is => 'rw', isa => 'ArrayRef[Employee]', default => sub { [] }, ); sub BUILD { my ( $self, $params ) = @_; foreach my $employee ( @{ $self->employees } ) { $employee->employer($self); } } after 'employees' => sub { my ( $self, $employees ) = @_; return unless $employees; foreach my $employee ( @$employees ) { $employee->employer($self); } }; package Person; use Moose; has 'first_name' => ( is => 'rw', isa => 'Str', required => 1 ); has 'last_name' => ( is => 'rw', isa => 'Str', required => 1 ); has 'middle_initial' => ( is => 'rw', isa => 'Str', predicate => 'has_middle_initial' ); has 'address' => ( is => 'rw', isa => 'Address' ); sub full_name { my $self = shift; return $self->first_name . ( $self->has_middle_initial ? ' ' . $self->middle_initial . '. ' : ' ' ) . $self->last_name; } package Employee; use Moose; extends 'Person'; has 'title' => ( is => 'rw', isa => 'Str', required => 1 ); has 'employer' => ( is => 'rw', isa => 'Company', weak_ref => 1 ); override 'full_name' => sub { my $self = shift; super() . ', ' . $self->title; }; } # =begin testing { { package Company; sub get_employee_count { scalar @{(shift)->employees} } } use Scalar::Util 'isweak'; my $ii; is( exception { $ii = Company->new( { name => 'Infinity Interactive', address => Address->new( street => '565 Plandome Rd., Suite 307', city => 'Manhasset', state => 'NY', zip_code => '11030' ), employees => [ Employee->new( first_name => 'Jeremy', last_name => 'Shao', title => 'President / Senior Consultant', address => Address->new( city => 'Manhasset', state => 'NY' ) ), Employee->new( first_name => 'Tommy', last_name => 'Lee', title => 'Vice President / Senior Developer', address => Address->new( city => 'New York', state => 'NY' ) ), Employee->new( first_name => 'Stevan', middle_initial => 'C', last_name => 'Little', title => 'Senior Developer', address => Address->new( city => 'Madison', state => 'CT' ) ), ] } ); }, undef, '... created the entire company successfully' ); isa_ok( $ii, 'Company' ); is( $ii->name, 'Infinity Interactive', '... got the right name for the company' ); isa_ok( $ii->address, 'Address' ); is( $ii->address->street, '565 Plandome Rd., Suite 307', '... got the right street address' ); is( $ii->address->city, 'Manhasset', '... got the right city' ); is( $ii->address->state, 'NY', '... got the right state' ); is( $ii->address->zip_code, 11030, '... got the zip code' ); is( $ii->get_employee_count, 3, '... got the right employee count' ); # employee #1 isa_ok( $ii->employees->[0], 'Employee' ); isa_ok( $ii->employees->[0], 'Person' ); is( $ii->employees->[0]->first_name, 'Jeremy', '... got the right first name' ); is( $ii->employees->[0]->last_name, 'Shao', '... got the right last name' ); ok( !$ii->employees->[0]->has_middle_initial, '... no middle initial' ); is( $ii->employees->[0]->middle_initial, undef, '... got the right middle initial value' ); is( $ii->employees->[0]->full_name, 'Jeremy Shao, President / Senior Consultant', '... got the right full name' ); is( $ii->employees->[0]->title, 'President / Senior Consultant', '... got the right title' ); is( $ii->employees->[0]->employer, $ii, '... got the right company' ); ok( isweak( $ii->employees->[0]->{employer} ), '... the company is a weak-ref' ); isa_ok( $ii->employees->[0]->address, 'Address' ); is( $ii->employees->[0]->address->city, 'Manhasset', '... got the right city' ); is( $ii->employees->[0]->address->state, 'NY', '... got the right state' ); # employee #2 isa_ok( $ii->employees->[1], 'Employee' ); isa_ok( $ii->employees->[1], 'Person' ); is( $ii->employees->[1]->first_name, 'Tommy', '... got the right first name' ); is( $ii->employees->[1]->last_name, 'Lee', '... got the right last name' ); ok( !$ii->employees->[1]->has_middle_initial, '... no middle initial' ); is( $ii->employees->[1]->middle_initial, undef, '... got the right middle initial value' ); is( $ii->employees->[1]->full_name, 'Tommy Lee, Vice President / Senior Developer', '... got the right full name' ); is( $ii->employees->[1]->title, 'Vice President / Senior Developer', '... got the right title' ); is( $ii->employees->[1]->employer, $ii, '... got the right company' ); ok( isweak( $ii->employees->[1]->{employer} ), '... the company is a weak-ref' ); isa_ok( $ii->employees->[1]->address, 'Address' ); is( $ii->employees->[1]->address->city, 'New York', '... got the right city' ); is( $ii->employees->[1]->address->state, 'NY', '... got the right state' ); # employee #3 isa_ok( $ii->employees->[2], 'Employee' ); isa_ok( $ii->employees->[2], 'Person' ); is( $ii->employees->[2]->first_name, 'Stevan', '... got the right first name' ); is( $ii->employees->[2]->last_name, 'Little', '... got the right last name' ); ok( $ii->employees->[2]->has_middle_initial, '... got middle initial' ); is( $ii->employees->[2]->middle_initial, 'C', '... got the right middle initial value' ); is( $ii->employees->[2]->full_name, 'Stevan C. Little, Senior Developer', '... got the right full name' ); is( $ii->employees->[2]->title, 'Senior Developer', '... got the right title' ); is( $ii->employees->[2]->employer, $ii, '... got the right company' ); ok( isweak( $ii->employees->[2]->{employer} ), '... the company is a weak-ref' ); isa_ok( $ii->employees->[2]->address, 'Address' ); is( $ii->employees->[2]->address->city, 'Madison', '... got the right city' ); is( $ii->employees->[2]->address->state, 'CT', '... got the right state' ); # create new company my $new_company = Company->new( name => 'Infinity Interactive International' ); isa_ok( $new_company, 'Company' ); my $ii_employees = $ii->employees; foreach my $employee (@$ii_employees) { is( $employee->employer, $ii, '... has the ii company' ); } $new_company->employees($ii_employees); foreach my $employee ( @{ $new_company->employees } ) { is( $employee->employer, $new_company, '... has the different company now' ); } ## check some error conditions for the subtypes isnt( exception { Address->new( street => {} ),; }, undef, '... we die correctly with bad args' ); isnt( exception { Address->new( city => {} ),; }, undef, '... we die correctly with bad args' ); isnt( exception { Address->new( state => 'British Columbia' ),; }, undef, '... we die correctly with bad args' ); is( exception { Address->new( state => 'Connecticut' ),; }, undef, '... we live correctly with good args' ); isnt( exception { Address->new( zip_code => 'AF5J6$' ),; }, undef, '... we die correctly with bad args' ); is( exception { Address->new( zip_code => '06443' ),; }, undef, '... we live correctly with good args' ); isnt( exception { Company->new(),; }, undef, '... we die correctly without good args' ); is( exception { Company->new( name => 'Foo' ),; }, undef, '... we live correctly without good args' ); isnt( exception { Company->new( name => 'Foo', employees => [ Person->new ] ),; }, undef, '... we die correctly with good args' ); is( exception { Company->new( name => 'Foo', employees => [] ),; }, undef, '... we live correctly with good args' ); } 1; loading-benchmark.pl100755000767000024 116612200352345 21321 0ustar00etherstaff000000000000Moose-2.1005/benchmarks/cmop#!perl -w use strict; use Benchmark qw(:all); my ( $count, $module ) = @ARGV; $count ||= 10; $module ||= 'Moose'; my @blib = qw(-Iblib/lib -Iblib/arch -I../Moose/blib/lib -I../Moose/blib/arch -I../Moose/lib); $| = 1; # autoflush print 'Installed: '; system $^X, '-le', 'require Moose; print $INC{q{Moose.pm}}'; print 'Blead: '; system $^X, @blib, '-le', 'require Moose; print $INC{q{Moose.pm}}'; cmpthese timethese $count => { released => sub { system( $^X, '-e', "require $module" ) == 0 or die; }, blead => sub { system( $^X, @blib, '-e', "require $module" ) == 0 or die; }, }; Point3D.pm100644000767000024 71712200352345 21024 0ustar00etherstaff000000000000Moose-2.1005/benchmarks/cmop/lib/Plain#!/usr/bin/perl package Plain::Point3D; use strict; use warnings; use base 'Plain::Point'; sub new { my ( $class, %params ) = @_; my $self = $class->SUPER::new( %params ); $self->{z} = $params{z}; return $self; } sub z { my ( $self, @args ) = @_; if ( @args ) { $self->{z} = $args[0]; } return $self->{z}; } sub clear { my $self = shift; $self->SUPER::clear(); $self->{z} = 0; } __PACKAGE__; __END__ AttributeCore.pm100644000767000024 472712200352345 21013 0ustar00etherstaff000000000000Moose-2.1005/lib/Class/MOP/Mixinpackage Class::MOP::Mixin::AttributeCore; BEGIN { $Class::MOP::Mixin::AttributeCore::AUTHORITY = 'cpan:STEVAN'; } { $Class::MOP::Mixin::AttributeCore::VERSION = '2.1005'; } use strict; use warnings; use Scalar::Util 'blessed'; use base 'Class::MOP::Mixin'; sub has_accessor { defined $_[0]->{'accessor'} } sub has_reader { defined $_[0]->{'reader'} } sub has_writer { defined $_[0]->{'writer'} } sub has_predicate { defined $_[0]->{'predicate'} } sub has_clearer { defined $_[0]->{'clearer'} } sub has_builder { defined $_[0]->{'builder'} } sub has_init_arg { defined $_[0]->{'init_arg'} } sub has_default { exists $_[0]->{'default'} } sub has_initializer { defined $_[0]->{'initializer'} } sub has_insertion_order { defined $_[0]->{'insertion_order'} } sub _set_insertion_order { $_[0]->{'insertion_order'} = $_[1] } sub has_read_method { $_[0]->has_reader || $_[0]->has_accessor } sub has_write_method { $_[0]->has_writer || $_[0]->has_accessor } sub is_default_a_coderef { # Uber hack because it is called from CMOP::Attribute constructor as # $class->is_default_a_coderef(\%options) my ($value) = ref $_[0] ? $_[0]->{'default'} : $_[1]->{'default'}; return unless ref($value); return ref($value) eq 'CODE' || ( blessed($value) && $value->isa('Class::MOP::Method') ); } sub default { my ( $self, $instance ) = @_; if ( defined $instance && $self->is_default_a_coderef ) { # if the default is a CODE ref, then we pass in the instance and # default can return a value based on that instance. Somewhat crude, # but works. return $self->{'default'}->($instance); } $self->{'default'}; } 1; # ABSTRACT: Core attributes shared by attribute metaclasses __END__ =pod =head1 NAME Class::MOP::Mixin::AttributeCore - Core attributes shared by attribute metaclasses =head1 VERSION version 2.1005 =head1 DESCRIPTION This class implements the core attributes (aka properties) shared by all attributes. See the L documentation for API details. =head1 AUTHOR Moose is maintained by the Moose Cabal, along with the help of many contributors. See L and L for details. =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2013 by Infinity Interactive, Inc.. This is free software; you can redistribute it and/or modify it under the same terms as the Perl 5 programming language system itself. =cut HasAttributes.pm100644000767000024 647212200352345 21020 0ustar00etherstaff000000000000Moose-2.1005/lib/Class/MOP/Mixinpackage Class::MOP::Mixin::HasAttributes; BEGIN { $Class::MOP::Mixin::HasAttributes::AUTHORITY = 'cpan:STEVAN'; } { $Class::MOP::Mixin::HasAttributes::VERSION = '2.1005'; } use strict; use warnings; use Carp 'confess'; use Scalar::Util 'blessed'; use base 'Class::MOP::Mixin'; sub add_attribute { my $self = shift; my $attribute = blessed( $_[0] ) ? $_[0] : $self->attribute_metaclass->new(@_); ( $attribute->isa('Class::MOP::Mixin::AttributeCore') ) || confess "Your attribute must be an instance of Class::MOP::Mixin::AttributeCore (or a subclass)"; $self->_attach_attribute($attribute); my $attr_name = $attribute->name; $self->remove_attribute($attr_name) if $self->has_attribute($attr_name); my $order = ( scalar keys %{ $self->_attribute_map } ); $attribute->_set_insertion_order($order); $self->_attribute_map->{$attr_name} = $attribute; # This method is called to allow for installing accessors. Ideally, we'd # use method overriding, but then the subclass would be responsible for # making the attribute, which would end up with lots of code # duplication. Even more ideally, we'd use augment/inner, but this is # Class::MOP! $self->_post_add_attribute($attribute) if $self->can('_post_add_attribute'); return $attribute; } sub has_attribute { my ( $self, $attribute_name ) = @_; ( defined $attribute_name ) || confess "You must define an attribute name"; exists $self->_attribute_map->{$attribute_name}; } sub get_attribute { my ( $self, $attribute_name ) = @_; ( defined $attribute_name ) || confess "You must define an attribute name"; return $self->_attribute_map->{$attribute_name}; } sub remove_attribute { my ( $self, $attribute_name ) = @_; ( defined $attribute_name ) || confess "You must define an attribute name"; my $removed_attribute = $self->_attribute_map->{$attribute_name}; return unless defined $removed_attribute; delete $self->_attribute_map->{$attribute_name}; return $removed_attribute; } sub get_attribute_list { my $self = shift; keys %{ $self->_attribute_map }; } sub _restore_metaattributes_from { my $self = shift; my ($old_meta) = @_; for my $attr (sort { $a->insertion_order <=> $b->insertion_order } map { $old_meta->get_attribute($_) } $old_meta->get_attribute_list) { $attr->_make_compatible_with($self->attribute_metaclass); $self->add_attribute($attr); } } 1; # ABSTRACT: Methods for metaclasses which have attributes __END__ =pod =head1 NAME Class::MOP::Mixin::HasAttributes - Methods for metaclasses which have attributes =head1 VERSION version 2.1005 =head1 DESCRIPTION This class implements methods for metaclasses which have attributes (L and L). See L for API details. =head1 AUTHOR Moose is maintained by the Moose Cabal, along with the help of many contributors. See L and L for details. =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2013 by Infinity Interactive, Inc.. This is free software; you can redistribute it and/or modify it under the same terms as the Perl 5 programming language system itself. =cut MethodModifiers.pod100644000767000024 2157012200352345 21215 0ustar00etherstaff000000000000Moose-2.1005/lib/Moose/Manualpackage Moose::Manual::MethodModifiers; # ABSTRACT: Moose's method modifiers __END__ =pod =head1 NAME Moose::Manual::MethodModifiers - Moose's method modifiers =head1 VERSION version 2.1005 =head1 WHAT IS A METHOD MODIFIER? Moose provides a feature called "method modifiers". You can also think of these as "hooks" or "advice". It's probably easiest to understand this feature with a few examples: package Example; use Moose; sub foo { print " foo\n"; } before 'foo' => sub { print "about to call foo\n"; }; after 'foo' => sub { print "just called foo\n"; }; around 'foo' => sub { my $orig = shift; my $self = shift; print " I'm around foo\n"; $self->$orig(@_); print " I'm still around foo\n"; }; Now if I call C<< Example->new->foo >> I'll get the following output: about to call foo I'm around foo foo I'm still around foo just called foo You probably could have figured that out from the names "before", "after", and "around". Also, as you can see, the before modifiers come before around modifiers, and after modifiers come last. When there are multiple modifiers of the same type, the before and around modifiers run from the last added to the first, and after modifiers run from first added to last: before 2 before 1 around 2 around 1 primary around 1 around 2 after 1 after 2 =head1 WHY USE THEM? Method modifiers have many uses. They are often used in roles to alter the behavior of methods in the classes that consume the role. See L for more information about roles. Since modifiers are mostly useful in roles, some of the examples below are a bit artificial. They're intended to give you an idea of how modifiers work, but may not be the most natural usage. =head1 BEFORE, AFTER, AND AROUND Method modifiers can be used to add behavior to methods without modifying the definition of those methods. =head2 BEFORE and AFTER modifiers Method modifiers can be used to add behavior to a method that Moose generates for you, such as an attribute accessor: has 'size' => ( is => 'rw' ); before 'size' => sub { my $self = shift; if (@_) { Carp::cluck('Someone is setting size'); } }; Another use for the before modifier would be to do some sort of prechecking on a method call. For example: before 'size' => sub { my $self = shift; die 'Cannot set size while the person is growing' if @_ && $self->is_growing; }; This lets us implement logical checks that don't make sense as type constraints. In particular, they're useful for defining logical rules about an object's state changes. Similarly, an after modifier could be used for logging an action that was taken. Note that the return values of both before and after modifiers are ignored. =head2 AROUND modifiers An around modifier is more powerful than either a before or after modifier. It can modify the arguments being passed to the original method, and you can even decide to simply not call the original method at all. You can also modify the return value with an around modifier. An around modifier receives the original method as its first argument, I the object, and finally any arguments passed to the method. around 'size' => sub { my $orig = shift; my $self = shift; return $self->$orig() unless @_; my $size = shift; $size = $size / 2 if $self->likes_small_things(); return $self->$orig($size); }; =head2 Wrapping multiple methods at once C, C, and C can also modify multiple methods at once. The simplest example of this is passing them as a list: before [qw(foo bar baz)] => sub { warn "something is being called!"; }; This will add a C modifier to each of the C, C, and C methods in the current class, just as though a separate call to C was made for each of them. The list can be passed either as a bare list, or as an arrayref. Note that the name of the function being modified isn't passed in in any way; this syntax is only intended for cases where the function being modified doesn't actually matter. If the function name does matter, use something like this: for my $func (qw(foo bar baz)) { before $func => sub { warn "$func was called!"; }; } =head2 Using regular expressions to select methods to wrap In addition, you can specify a regular expression to indicate the methods to wrap, like so: after qr/^command_/ => sub { warn "got a command"; }; This will match the regular expression against each method name returned by L, and add a modifier to each one that matches. The same caveats apply as above. Using regular expressions to determine methods to wrap is quite a bit more powerful than the previous alternatives, but it's also quite a bit more dangerous. Bear in mind that if your regular expression matches certain Perl and Moose reserved method names with a special meaning to Moose or Perl, such as C, C, C, C, C, etc, this could cause unintended (and hard to debug) problems and is best avoided. =head1 INNER AND AUGMENT Augment and inner are two halves of the same feature. The augment modifier provides a sort of inverted subclassing. You provide part of the implementation in a superclass, and then document that subclasses are expected to provide the rest. The superclass calls C, which then calls the C modifier in the subclass: package Document; use Moose; sub as_xml { my $self = shift; my $xml = "\n"; $xml .= inner(); $xml .= "\n"; return $xml; } Using C in this method makes it possible for one or more subclasses to then augment this method with their own specific implementation: package Report; use Moose; extends 'Document'; augment 'as_xml' => sub { my $self = shift; my $xml = " \n"; $xml .= inner(); $xml .= " \n"; return $xml; }; When we call C on a Report object, we get something like this: But we also called C in C, so we can continue subclassing and adding more content inside the document: package Report::IncomeAndExpenses; use Moose; extends 'Report'; augment 'as_xml' => sub { my $self = shift; my $xml = ' ' . $self->income . ''; $xml .= "\n"; $xml .= ' ' . $self->expenses . ''; $xml .= "\n"; $xml .= inner() || q{}; return $xml; }; Now our report has some content: $10 $8 What makes this combination of C and C special is that it allows us to have methods which are called from parent (least specific) to child (most specific). This inverts the normal inheritance pattern. Note that in C we call C again. If the object is an instance of C then this call is a no-op, and just returns false. It's a good idea to always call C to allow for future subclassing. =head1 OVERRIDE AND SUPER Finally, Moose provides some simple sugar for Perl's built-in method overriding scheme. If you want to override a method from a parent class, you can do this with C: package Employee; use Moose; extends 'Person'; has 'job_title' => ( is => 'rw' ); override 'display_name' => sub { my $self = shift; return super() . q{, } . $self->title(); }; The call to C is almost the same as calling C<< $self->SUPER::display_name >>. The difference is that the arguments passed to the superclass's method will always be the same as the ones passed to the method modifier, and cannot be changed. All arguments passed to C are ignored, as are any changes made to C<@_> before C is called. =head1 SEMI-COLONS Because all of these method modifiers are implemented as Perl functions, you must always end the modifier declaration with a semi-colon: after 'foo' => sub { }; =head1 CAVEATS These method modification features do not work well with multiple inheritance, due to how method resolution is performed in Perl. Experiment with a test program to ensure your class hierarchy works as expected, or more preferably, don't use multiple inheritance (roles can help with this)! =head1 AUTHOR Moose is maintained by the Moose Cabal, along with the help of many contributors. See L and L for details. =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2013 by Infinity Interactive, Inc.. This is free software; you can redistribute it and/or modify it under the same terms as the Perl 5 programming language system itself. =cut Constructor.pm100644000767000024 477112200352345 21167 0ustar00etherstaff000000000000Moose-2.1005/lib/Moose/Meta/Method package Moose::Meta::Method::Constructor; BEGIN { $Moose::Meta::Method::Constructor::AUTHORITY = 'cpan:STEVAN'; } { $Moose::Meta::Method::Constructor::VERSION = '2.1005'; } use strict; use warnings; use Carp (); use List::MoreUtils 'any'; use Scalar::Util 'blessed', 'weaken', 'looks_like_number', 'refaddr'; use Try::Tiny; use base 'Moose::Meta::Method', 'Class::MOP::Method::Constructor'; sub new { my $class = shift; my %options = @_; my $meta = $options{metaclass}; (ref $options{options} eq 'HASH') || $class->throw_error("You must pass a hash of options", data => $options{options}); ($options{package_name} && $options{name}) || $class->throw_error("You must supply the package_name and name parameters $Class::MOP::Method::UPGRADE_ERROR_TEXT"); my $self = bless { 'body' => undef, 'package_name' => $options{package_name}, 'name' => $options{name}, 'options' => $options{options}, 'associated_metaclass' => $meta, 'definition_context' => $options{definition_context}, '_expected_method_class' => $options{_expected_method_class} || 'Moose::Object', } => $class; # we don't want this creating # a cycle in the code, if not # needed weaken($self->{'associated_metaclass'}); $self->_initialize_body; return $self; } ## method sub _initialize_body { my $self = shift; $self->{'body'} = $self->_generate_constructor_method_inline; } 1; # ABSTRACT: Method Meta Object for constructors __END__ =pod =head1 NAME Moose::Meta::Method::Constructor - Method Meta Object for constructors =head1 VERSION version 2.1005 =head1 DESCRIPTION This class is a subclass of L that provides additional Moose-specific functionality To understand this class, you should read the the L documentation as well. =head1 INHERITANCE C is a subclass of L I L. =head1 BUGS See L for details on reporting bugs. =head1 AUTHOR Moose is maintained by the Moose Cabal, along with the help of many contributors. See L and L for details. =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2013 by Infinity Interactive, Inc.. This is free software; you can redistribute it and/or modify it under the same terms as the Perl 5 programming language system itself. =cut TypeCoercion000755000767000024 012200352345 17316 5ustar00etherstaff000000000000Moose-2.1005/lib/Moose/MetaUnion.pm100644000767000024 447112200352345 21112 0ustar00etherstaff000000000000Moose-2.1005/lib/Moose/Meta/TypeCoercion package Moose::Meta::TypeCoercion::Union; BEGIN { $Moose::Meta::TypeCoercion::Union::AUTHORITY = 'cpan:STEVAN'; } { $Moose::Meta::TypeCoercion::Union::VERSION = '2.1005'; } use strict; use warnings; use metaclass; use Scalar::Util 'blessed'; use base 'Moose::Meta::TypeCoercion'; sub compile_type_coercion { my $self = shift; my $type_constraint = $self->type_constraint; (blessed $type_constraint && $type_constraint->isa('Moose::Meta::TypeConstraint::Union')) || Moose->throw_error("You can only create a Moose::Meta::TypeCoercion::Union for a " . "Moose::Meta::TypeConstraint::Union, not a $type_constraint"); $self->_compiled_type_coercion( sub { my $value = shift; foreach my $type ( grep { $_->has_coercion } @{ $type_constraint->type_constraints } ) { my $temp = $type->coerce($value); return $temp if $type_constraint->check($temp); } return $value; } ); } sub has_coercion_for_type { 0 } sub add_type_coercions { require Moose; Moose->throw_error("Cannot add additional type coercions to Union types"); } 1; # ABSTRACT: The Moose Type Coercion metaclass for Unions __END__ =pod =head1 NAME Moose::Meta::TypeCoercion::Union - The Moose Type Coercion metaclass for Unions =head1 VERSION version 2.1005 =head1 DESCRIPTION This is a subclass of L that is used for L objects. =head1 METHODS =over 4 =item B<< $coercion->has_coercion_for_type >> This method always returns false. =item B<< $coercion->add_type_coercions >> This method always throws an error. You cannot add coercions to a union type coercion. =item B<< $coercion->coerce($value) >> This method will coerce by trying the coercions for each type in the union. =back =head1 BUGS See L for details on reporting bugs. =head1 AUTHOR Moose is maintained by the Moose Cabal, along with the help of many contributors. See L and L for details. =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2013 by Infinity Interactive, Inc.. This is free software; you can redistribute it and/or modify it under the same terms as the Perl 5 programming language system itself. =cut attr_dereference_test.t100644000767000024 303312200352345 21512 0ustar00etherstaff000000000000Moose-2.1005/t/attributes#!/usr/bin/perl use strict; use warnings; use Test::More; use Test::Fatal; { package Customer; use Moose; package Firm; use Moose; use Moose::Util::TypeConstraints; ::is( ::exception { has 'customers' => ( is => 'ro', isa => subtype('ArrayRef' => where { (blessed($_) && $_->isa('Customer') || return) for @$_; 1 }), auto_deref => 1, ); }, undef, '... successfully created attr' ); } { my $customer = Customer->new; isa_ok($customer, 'Customer'); my $firm = Firm->new(customers => [ $customer ]); isa_ok($firm, 'Firm'); can_ok($firm, 'customers'); is_deeply( [ $firm->customers ], [ $customer ], '... got the right dereferenced value' ); } { my $firm = Firm->new(); isa_ok($firm, 'Firm'); can_ok($firm, 'customers'); is_deeply( [ $firm->customers ], [], '... got the right dereferenced value' ); } { package AutoDeref; use Moose; has 'bar' => ( is => 'rw', isa => 'ArrayRef[Int]', auto_deref => 1, ); } { my $autoderef = AutoDeref->new; isnt( exception { $autoderef->bar(1, 2, 3); }, undef, '... its auto-de-ref-ing, not auto-en-ref-ing' ); is( exception { $autoderef->bar([ 1, 2, 3 ]) }, undef, '... set the results of bar correctly' ); is_deeply [ $autoderef->bar ], [ 1, 2, 3 ], '... auto-dereffed correctly'; } done_testing; attribute_type_unions.t100644000767000024 415312200352345 21615 0ustar00etherstaff000000000000Moose-2.1005/t/attributes#!/usr/bin/perl use strict; use warnings; use Test::More; use Test::Fatal; { package Foo; use Moose; has 'bar' => (is => 'rw', isa => 'ArrayRef | HashRef'); } my $foo = Foo->new; isa_ok($foo, 'Foo'); is( exception { $foo->bar([]) }, undef, '... set bar successfully with an ARRAY ref' ); is( exception { $foo->bar({}) }, undef, '... set bar successfully with a HASH ref' ); isnt( exception { $foo->bar(100) }, undef, '... couldnt set bar successfully with a number' ); isnt( exception { $foo->bar(sub {}) }, undef, '... couldnt set bar successfully with a CODE ref' ); # check the constructor is( exception { Foo->new(bar => []) }, undef, '... created new Foo with bar successfully set with an ARRAY ref' ); is( exception { Foo->new(bar => {}) }, undef, '... created new Foo with bar successfully set with a HASH ref' ); isnt( exception { Foo->new(bar => 50) }, undef, '... didnt create a new Foo with bar as a number' ); isnt( exception { Foo->new(bar => sub {}) }, undef, '... didnt create a new Foo with bar as a CODE ref' ); { package Bar; use Moose; has 'baz' => (is => 'rw', isa => 'Str | CodeRef'); } my $bar = Bar->new; isa_ok($bar, 'Bar'); is( exception { $bar->baz('a string') }, undef, '... set baz successfully with a string' ); is( exception { $bar->baz(sub { 'a sub' }) }, undef, '... set baz successfully with a CODE ref' ); isnt( exception { $bar->baz(\(my $var1)) }, undef, '... couldnt set baz successfully with a SCALAR ref' ); isnt( exception { $bar->baz({}) }, undef, '... couldnt set bar successfully with a HASH ref' ); # check the constructor is( exception { Bar->new(baz => 'a string') }, undef, '... created new Bar with baz successfully set with a string' ); is( exception { Bar->new(baz => sub { 'a sub' }) }, undef, '... created new Bar with baz successfully set with a CODE ref' ); isnt( exception { Bar->new(baz => \(my $var2)) }, undef, '... didnt create a new Bar with baz as a number' ); isnt( exception { Bar->new(baz => {}) }, undef, '... didnt create a new Bar with baz as a HASH ref' ); done_testing; application_metarole_compat.t100644000767000024 177712200352345 21477 0ustar00etherstaff000000000000Moose-2.1005/t/bugs#!/usr/bin/env perl use strict; use warnings; use Test::More; use Test::Fatal; BEGIN { { package Foo; use Moose::Role; } { package Bar::Class; use Moose::Role; } { package Bar::ToClass; use Moose::Role; after apply => sub { my $self = shift; my ($role, $class) = @_; Moose::Util::MetaRole::apply_metaroles( for => $class, class_metaroles => { class => ['Bar::Class'], } ); }; } { package Bar; use Moose::Role; Moose::Util::MetaRole::apply_metaroles( for => __PACKAGE__, role_metaroles => { application_to_class => ['Bar::ToClass'], } ); } } { package Parent; use Moose -traits => 'Foo'; } { package Child; use Moose -traits => 'Bar'; ::is( ::exception { extends 'Parent' }, undef ); } done_testing; constructor_object_overload.t100644000767000024 44612200352345 21517 0ustar00etherstaff000000000000Moose-2.1005/t/bugs#!/usr/bin/perl use strict; use warnings; use Test::More; { package Foo; use Moose; use overload '""' => sub {''}; sub bug { 'plenty' } __PACKAGE__->meta->make_immutable; } ok(Foo->new()->bug(), 'call constructor on object reference with overloading'); done_testing; class_errors_and_edge_cases.t100644000767000024 1367012200352345 21437 0ustar00etherstaff000000000000Moose-2.1005/t/cmopuse strict; use warnings; use Test::More; use Test::Fatal; use Class::MOP; { isnt( exception { Class::MOP::Class->initialize(); }, undef, '... initialize requires a name parameter' ); isnt( exception { Class::MOP::Class->initialize(''); }, undef, '... initialize requires a name valid parameter' ); isnt( exception { Class::MOP::Class->initialize(bless {} => 'Foo'); }, undef, '... initialize requires an unblessed parameter' ); } { isnt( exception { Class::MOP::Class->_construct_class_instance(); }, undef, '... _construct_class_instance requires an :package parameter' ); isnt( exception { Class::MOP::Class->_construct_class_instance(':package' => undef); }, undef, '... _construct_class_instance requires a defined :package parameter' ); isnt( exception { Class::MOP::Class->_construct_class_instance(':package' => ''); }, undef, '... _construct_class_instance requires a valid :package parameter' ); } { isnt( exception { Class::MOP::Class->create(); }, undef, '... create requires an package_name parameter' ); isnt( exception { Class::MOP::Class->create(undef); }, undef, '... create requires a defined package_name parameter' ); isnt( exception { Class::MOP::Class->create(''); }, undef, '... create requires a valid package_name parameter' ); isnt( exception { Class::MOP::Class->create('+++'); }, qr/^\+\+\+ is not a module name/, '... create requires a valid package_name parameter' ); } { isnt( exception { Class::MOP::Class->clone_object(1); }, undef, '... can only clone instances' ); } { isnt( exception { Class::MOP::Class->add_method(); }, undef, '... add_method dies as expected' ); isnt( exception { Class::MOP::Class->add_method(''); }, undef, '... add_method dies as expected' ); isnt( exception { Class::MOP::Class->add_method('foo' => 'foo'); }, undef, '... add_method dies as expected' ); isnt( exception { Class::MOP::Class->add_method('foo' => []); }, undef, '... add_method dies as expected' ); } { isnt( exception { Class::MOP::Class->has_method(); }, undef, '... has_method dies as expected' ); isnt( exception { Class::MOP::Class->has_method(''); }, undef, '... has_method dies as expected' ); } { isnt( exception { Class::MOP::Class->get_method(); }, undef, '... get_method dies as expected' ); isnt( exception { Class::MOP::Class->get_method(''); }, undef, '... get_method dies as expected' ); } { isnt( exception { Class::MOP::Class->remove_method(); }, undef, '... remove_method dies as expected' ); isnt( exception { Class::MOP::Class->remove_method(''); }, undef, '... remove_method dies as expected' ); } { isnt( exception { Class::MOP::Class->find_all_methods_by_name(); }, undef, '... find_all_methods_by_name dies as expected' ); isnt( exception { Class::MOP::Class->find_all_methods_by_name(''); }, undef, '... find_all_methods_by_name dies as expected' ); } { isnt( exception { Class::MOP::Class->add_attribute(bless {} => 'Foo'); }, undef, '... add_attribute dies as expected' ); } { isnt( exception { Class::MOP::Class->has_attribute(); }, undef, '... has_attribute dies as expected' ); isnt( exception { Class::MOP::Class->has_attribute(''); }, undef, '... has_attribute dies as expected' ); } { isnt( exception { Class::MOP::Class->get_attribute(); }, undef, '... get_attribute dies as expected' ); isnt( exception { Class::MOP::Class->get_attribute(''); }, undef, '... get_attribute dies as expected' ); } { isnt( exception { Class::MOP::Class->remove_attribute(); }, undef, '... remove_attribute dies as expected' ); isnt( exception { Class::MOP::Class->remove_attribute(''); }, undef, '... remove_attribute dies as expected' ); } { isnt( exception { Class::MOP::Class->add_package_symbol(); }, undef, '... add_package_symbol dies as expected' ); isnt( exception { Class::MOP::Class->add_package_symbol(''); }, undef, '... add_package_symbol dies as expected' ); isnt( exception { Class::MOP::Class->add_package_symbol('foo'); }, undef, '... add_package_symbol dies as expected' ); isnt( exception { Class::MOP::Class->add_package_symbol('&foo'); }, undef, '... add_package_symbol dies as expected' ); # throws_ok { # Class::MOP::Class->meta->add_package_symbol('@-'); # } qr/^Could not create package variable \(\@\-\) because/, # '... add_package_symbol dies as expected'; } { isnt( exception { Class::MOP::Class->has_package_symbol(); }, undef, '... has_package_symbol dies as expected' ); isnt( exception { Class::MOP::Class->has_package_symbol(''); }, undef, '... has_package_symbol dies as expected' ); isnt( exception { Class::MOP::Class->has_package_symbol('foo'); }, undef, '... has_package_symbol dies as expected' ); } { isnt( exception { Class::MOP::Class->get_package_symbol(); }, undef, '... get_package_symbol dies as expected' ); isnt( exception { Class::MOP::Class->get_package_symbol(''); }, undef, '... get_package_symbol dies as expected' ); isnt( exception { Class::MOP::Class->get_package_symbol('foo'); }, undef, '... get_package_symbol dies as expected' ); } { isnt( exception { Class::MOP::Class->remove_package_symbol(); }, undef, '... remove_package_symbol dies as expected' ); isnt( exception { Class::MOP::Class->remove_package_symbol(''); }, undef, '... remove_package_symbol dies as expected' ); isnt( exception { Class::MOP::Class->remove_package_symbol('foo'); }, undef, '... remove_package_symbol dies as expected' ); } done_testing; instance_metaclass_incompat.t100644000767000024 305512200352345 21460 0ustar00etherstaff000000000000Moose-2.1005/t/cmopuse strict; use warnings; use Test::More; use metaclass; # meta classes { package Foo::Meta::Instance; use base 'Class::MOP::Instance'; package Bar::Meta::Instance; use base 'Class::MOP::Instance'; package FooBar::Meta::Instance; use base 'Foo::Meta::Instance', 'Bar::Meta::Instance'; } $@ = undef; eval { package Foo; BEGIN { $INC{'Foo.pm'} = __FILE__ } metaclass->import('instance_metaclass' => 'Foo::Meta::Instance'); }; ok(!$@, '... Foo.meta => Foo::Meta is compatible') || diag $@; $@ = undef; eval { package Bar; BEGIN { $INC{'Bar.pm'} = __FILE__ } metaclass->import('instance_metaclass' => 'Bar::Meta::Instance'); }; ok(!$@, '... Bar.meta => Bar::Meta is compatible') || diag $@; $@ = undef; eval { package Foo::Foo; use base 'Foo'; metaclass->import('instance_metaclass' => 'Bar::Meta::Instance'); }; ok($@, '... Foo::Foo.meta => Bar::Meta is not compatible') || diag $@; $@ = undef; eval { package Bar::Bar; use base 'Bar'; metaclass->import('instance_metaclass' => 'Foo::Meta::Instance'); }; ok($@, '... Bar::Bar.meta => Foo::Meta is not compatible') || diag $@; $@ = undef; eval { package FooBar; use base 'Foo'; metaclass->import('instance_metaclass' => 'FooBar::Meta::Instance'); }; ok(!$@, '... FooBar.meta => FooBar::Meta is compatible') || diag $@; $@ = undef; eval { package FooBar2; use base 'Bar'; metaclass->import('instance_metaclass' => 'FooBar::Meta::Instance'); }; ok(!$@, '... FooBar2.meta => FooBar::Meta is compatible') || diag $@; done_testing; constructor_is_wrapped.t100644000767000024 104012200352345 21541 0ustar00etherstaff000000000000Moose-2.1005/t/immutable#!/usr/bin/perl use strict; use warnings; use Test::More; use Test::Requires { 'Test::Output' => '0.01', # skip all if not installed }; { package ModdedNew; use Moose; before 'new' => sub { }; } { package Foo; use Moose; extends 'ModdedNew'; ::stderr_like( sub { Foo->meta->make_immutable }, qr/\QNot inlining 'new' for Foo since it has method modifiers which would be lost if it were inlined/, 'got a warning that Foo may not have an inlined constructor' ); } done_testing; exporter_meta_lookup.t100644000767000024 245012200352345 21541 0ustar00etherstaff000000000000Moose-2.1005/t/metaclasses#!/usr/bin/perl use strict; use warnings; use Test::More; use Test::Fatal; { package Class::Vacuum::Innards; use Moose; package Class::Vacuum; use Moose (); use Moose::Exporter; sub meta_lookup { $_[0] } BEGIN { Moose::Exporter->setup_import_methods( also => 'Moose', meta_lookup => sub { Class::MOP::class_of('Class::Vacuum::Innards') }, with_meta => ['meta_lookup'], ); } } { package Victim; BEGIN { Class::Vacuum->import }; has star_rod => ( is => 'ro', ); ::is(meta_lookup, Class::Vacuum::Innards->meta, "right meta_lookup"); } ok(Class::Vacuum::Innards->can('star_rod'), 'Vacuum stole the star_rod method'); ok(!Victim->can('star_rod'), 'Victim does not get it at all'); { package Class::Vacuum::Reexport; use Moose::Exporter; BEGIN { Moose::Exporter->setup_import_methods(also => 'Class::Vacuum'); } } { package Victim2; BEGIN { Class::Vacuum::Reexport->import } has parasol => ( is => 'ro', ); ::is(meta_lookup, Class::Vacuum::Innards->meta, "right meta_lookup"); } ok(Class::Vacuum::Innards->can('parasol'), 'Vacuum stole the parasol method'); ok(!Victim2->can('parasol'), 'Victim does not get it at all'); done_testing; metarole_combination.t100644000767000024 1313512200352345 21506 0ustar00etherstaff000000000000Moose-2.1005/t/metaclassesuse strict; use warnings; use Test::More; our @applications; { package CustomApplication; use Moose::Role; after apply_methods => sub { my ( $self, $role, $other ) = @_; $self->apply_custom( $role, $other ); }; sub apply_custom { shift; push @applications, [@_]; } } { package CustomApplication::ToClass; use Moose::Role; with 'CustomApplication'; } { package CustomApplication::ToRole; use Moose::Role; with 'CustomApplication'; } { package CustomApplication::ToInstance; use Moose::Role; with 'CustomApplication'; } { package CustomApplication::Composite; use Moose::Role; with 'CustomApplication'; around apply_custom => sub { my ( $next, $self, $composite, $other ) = @_; for my $role ( @{ $composite->get_roles } ) { $self->$next( $role, $other ); } }; } { package CustomApplication::Composite::ToClass; use Moose::Role; with 'CustomApplication::Composite'; } { package CustomApplication::Composite::ToRole; use Moose::Role; with 'CustomApplication::Composite'; } { package CustomApplication::Composite::ToInstance; use Moose::Role; with 'CustomApplication::Composite'; } { package Role::Composite; use Moose::Role; around apply_params => sub { my ( $next, $self, @args ) = @_; return Moose::Util::MetaRole::apply_metaroles( for => $self->$next(@args), role_metaroles => { application_to_class => ['CustomApplication::Composite::ToClass'], application_to_role => ['CustomApplication::Composite::ToRole'], application_to_instance => ['CustomApplication::Composite::ToInstance'], }, ); }; } { package Role::WithCustomApplication; use Moose::Role; around composition_class_roles => sub { my ($orig, $self) = @_; return $self->$orig, 'Role::Composite'; }; } { package CustomRole; Moose::Exporter->setup_import_methods( also => 'Moose::Role', ); sub init_meta { my ( $self, %options ) = @_; return Moose::Util::MetaRole::apply_metaroles( for => Moose::Role->init_meta(%options), role_metaroles => { role => ['Role::WithCustomApplication'], application_to_class => ['CustomApplication::ToClass'], application_to_role => ['CustomApplication::ToRole'], application_to_instance => ['CustomApplication::ToInstance'], }, ); } } { package My::Role::Normal; use Moose::Role; } { package My::Role::Special; CustomRole->import; } ok( My::Role::Normal->meta->isa('Moose::Meta::Role'), "sanity check" ); ok( My::Role::Special->meta->isa('Moose::Meta::Role'), "using custom application roles does not change the role metaobject's class" ); ok( My::Role::Special->meta->meta->does_role('Role::WithCustomApplication'), "the role's metaobject has custom applications" ); is_deeply( [My::Role::Special->meta->composition_class_roles], ['Role::Composite'], "the role knows about the specified composition class" ); { package Foo; use Moose; local @applications; with 'My::Role::Special'; ::is( @applications, 1, 'one role application' ); ::is( $applications[0]->[0]->name, 'My::Role::Special', "the application's first role was My::Role::Special'" ); ::is( $applications[0]->[1]->name, 'Foo', "the application provided an additional role" ); } { package Bar; use Moose::Role; local @applications; with 'My::Role::Special'; ::is( @applications, 1 ); ::is( $applications[0]->[0]->name, 'My::Role::Special' ); ::is( $applications[0]->[1]->name, 'Bar' ); } { package Baz; use Moose; my $i = Baz->new; local @applications; My::Role::Special->meta->apply($i); ::is( @applications, 1 ); ::is( $applications[0]->[0]->name, 'My::Role::Special' ); ::ok( $applications[0]->[1]->is_anon_class ); ::ok( $applications[0]->[1]->name->isa('Baz') ); } { package Corge; use Moose; local @applications; with 'My::Role::Normal', 'My::Role::Special'; ::is( @applications, 2 ); ::is( $applications[0]->[0]->name, 'My::Role::Normal' ); ::is( $applications[0]->[1]->name, 'Corge' ); ::is( $applications[1]->[0]->name, 'My::Role::Special' ); ::is( $applications[1]->[1]->name, 'Corge' ); } { package Thud; use Moose::Role; local @applications; with 'My::Role::Normal', 'My::Role::Special'; ::is( @applications, 2 ); ::is( $applications[0]->[0]->name, 'My::Role::Normal' ); ::is( $applications[0]->[1]->name, 'Thud' ); ::is( $applications[1]->[0]->name, 'My::Role::Special' ); ::is( $applications[1]->[1]->name, 'Thud' ); } { package Garply; use Moose; my $i = Garply->new; local @applications; Moose::Meta::Role->combine( [ 'My::Role::Normal' => undef ], [ 'My::Role::Special' => undef ], )->apply($i); ::is( @applications, 2 ); ::is( $applications[0]->[0]->name, 'My::Role::Normal' ); ::ok( $applications[0]->[1]->is_anon_class ); ::ok( $applications[0]->[1]->name->isa('Garply') ); ::is( $applications[1]->[0]->name, 'My::Role::Special' ); ::ok( $applications[1]->[1]->is_anon_class ); ::ok( $applications[1]->[1]->name->isa('Garply') ); } done_testing; runtime_roles_and_nonmoose.t100644000767000024 161512200352345 21542 0ustar00etherstaff000000000000Moose-2.1005/t/roles#!/usr/bin/perl use strict; use warnings; use Test::More; use Test::Fatal; use Scalar::Util 'blessed'; { package Dog; use Moose::Role; sub talk { 'woof' } package Foo; use Moose; has 'dog' => ( is => 'rw', does => 'Dog', ); no Moose; package Bar; sub new { return bless {}, shift; } } my $bar = Bar->new; isa_ok($bar, 'Bar'); my $foo = Foo->new; isa_ok($foo, 'Foo'); ok(!$bar->can( 'talk' ), "... the role is not composed yet"); isnt( exception { $foo->dog($bar) }, undef, '... and setting the accessor fails (not a Dog yet)' ); Dog->meta->apply($bar); ok($bar->can('talk'), "... the role is now composed at the object level"); is($bar->talk, 'woof', '... got the right return value for the newly composed method'); is( exception { $foo->dog($bar) }, undef, '... and setting the accessor is okay' ); done_testing; various_role_features.t100644000767000024 1640712200352345 21613 0ustar00etherstaff000000000000Moose-2.1005/t/todo_tests#!/usr/bin/perl use strict; use warnings; use Test::More; use Test::Fatal; sub req_or_has ($$) { my ( $role, $method ) = @_; local $Test::Builder::Level = $Test::Builder::Level + 1; if ( $role ) { ok( $role->has_method($method) || $role->requires_method($method), $role->name . " has or requires method $method" ); } else { fail("role has or requires method $method"); } } { package Bar; use Moose::Role; # this role eventually adds three methods, qw(foo bar xxy), but only one is # known when it's still a role has foo => ( is => "rw" ); has gorch => ( reader => "bar" ); sub xxy { "BAAAD" } package Gorch; use Moose::Role; # similarly this role gives attr and gorch_method has attr => ( is => "rw" ); sub gorch_method { "gorch method" } around dandy => sub { shift->(@_) . "bar" }; package Quxx; use Moose; sub dandy { "foo" } # this object will be used in an attr of Foo to test that Foo can do the # Gorch interface with qw(Gorch); package Dancer; use Moose::Role; requires "twist"; package Dancer::Ballerina; use Moose; with qw(Dancer); sub twist { } sub pirouette { } package Dancer::Robot; use Moose::Role; # this doesn't fail but it produces a requires in the role # the order doesn't matter has twist => ( is => "rw" ); ::is( ::exception { with qw(Dancer) }, undef ); package Dancer::Something; use Moose; # this fail even though the method already exists has twist => ( is => "rw" ); { ::is( ::exception { with qw(Dancer) }, undef ); } package Dancer::80s; use Moose; # this should pass because ::Robot has the attribute to fill in the requires # but due to the deferrence logic that doesn't actually work { local our $TODO = "attribute accessor in role doesn't satisfy role requires"; ::is( ::exception { with qw(Dancer::Robot) }, undef ); } package Foo; use Moose; with qw(Bar); has oink => ( is => "rw", handles => "Gorch", # should handles take the same arguments as 'with'? Meta::Role::Application::Delegation? default => sub { Quxx->new }, ); has dancer => ( is => "rw", does => "Dancer", handles => "Dancer", default => sub { Dancer::Ballerina->new }, ); sub foo { 42 } sub bar { 33 } sub xxy { 7 } package Tree; use Moose::Role; has bark => ( is => "rw" ); package Dog; use Moose::Role; sub bark { warn "woof!" }; package EntPuppy; use Moose; { local our $TODO = "attrs and methods from a role should clash"; ::isnt( ::exception { with qw(Tree Dog) }, undef ); } } # these fail because of the deferral logic winning over actual methods # this might be tricky to fix due to the 'sub foo {}; has foo => ( )' hack # we've been doing for a long while, though I doubt people relied on it for # anything other than fulfilling 'requires' { local $TODO = "attributes from role overwrite class methods"; is( Foo->new->foo, 42, "attr did not zap overriding method" ); is( Foo->new->bar, 33, "attr did not zap overriding method" ); } is( Foo->new->xxy, 7, "method did not zap overriding method" ); # duh # these pass, simple delegate # mostly they are here to contrast the next blck can_ok( Foo->new->oink, "dandy" ); can_ok( Foo->new->oink, "attr" ); can_ok( Foo->new->oink, "gorch_method" ); ok( Foo->new->oink->does("Gorch"), "Quxx does Gorch" ); # these are broken because 'attr' is not technically part of the interface can_ok( Foo->new, "gorch_method" ); { local $TODO = "accessor methods from a role are omitted in handles role"; can_ok( Foo->new, "attr" ); } { local $TODO = "handles role doesn't add the role to the ->does of the delegate's parent class"; ok( Foo->new->does("Gorch"), "Foo does Gorch" ); } # these work can_ok( Foo->new->dancer, "pirouette" ); can_ok( Foo->new->dancer, "twist" ); can_ok( Foo->new, "twist" ); ok( !Foo->new->can("pirouette"), "can't pirouette, not part of the iface" ); { local $TODO = "handles role doesn't add the role to the ->does of the delegate's parent class"; ok( Foo->new->does("Dancer") ); } my $gorch = Gorch->meta; isa_ok( $gorch, "Moose::Meta::Role" ); ok( $gorch->has_attribute("attr"), "has attribute 'attr'" ); isa_ok( $gorch->get_attribute("attr"), "Moose::Meta::Role::Attribute" ); req_or_has($gorch, "gorch_method"); ok( $gorch->has_method("gorch_method"), "has_method gorch_method" ); ok( !$gorch->requires_method("gorch_method"), "requires gorch method" ); isa_ok( $gorch->get_method("gorch_method"), "Moose::Meta::Method" ); { local $TODO = "method modifier doesn't yet create a method requirement or meta object"; req_or_has($gorch, "dandy" ); # this specific test is maybe not backwards compat, but in theory it *does* # require that method to exist ok( $gorch->requires_method("dandy"), "requires the dandy method for the modifier" ); } { local $TODO = "attribute related methods are not yet known by the role"; # we want this to be a part of the interface, somehow req_or_has($gorch, "attr"); ok( $gorch->has_method("attr"), "has_method attr" ); isa_ok( $gorch->get_method("attr"), "Moose::Meta::Method" ); isa_ok( $gorch->get_method("attr"), "Moose::Meta::Method::Accessor" ); } my $robot = Dancer::Robot->meta; isa_ok( $robot, "Moose::Meta::Role" ); ok( $robot->has_attribute("twist"), "has attr 'twist'" ); isa_ok( $robot->get_attribute("twist"), "Moose::Meta::Role::Attribute" ); { req_or_has($robot, "twist"); local $TODO = "attribute related methods are not yet known by the role"; ok( $robot->has_method("twist"), "has twist method" ); isa_ok( $robot->get_method("twist"), "Moose::Meta::Method" ); isa_ok( $robot->get_method("twist"), "Moose::Meta::Method::Accessor" ); } done_testing; __END__ I think Attribute needs to be refactored in some way to better support roles. There are several possible ways to do this, all of them seem plausible to me. The first approach would be to change the attribute class to allow it to be queried about the methods it would install. Then we instantiate the attribute in the role, and instead of deferring the arguments, we just make an Cish method. Then we can interrogate the attr when adding it to the role, and generate stub methods for all the methods it would produce. A second approach is kinda like the Immutable hack: wrap the attr in an anonmyous class that disables part of its interface. A third method would be to create an Attribute::Partial object that would provide a more role-ish behavior, and to do this independently of the actual Attribute class. Something similar can be done for method modifiers, but I think that's even simpler. The benefits of doing this are: * Much better introspection of roles * More correctness in many cases (in my opinion anyway) * More roles are more usable as interface declarations, without having to split them into two pieces (one for the interface with a bunch of requires(), and another for the actual impl with the problematic attrs (and stub methods to fix the accessors) and method modifiers (dunno if this can even work at all) misc_type_tests.t100644000767000024 401312200352345 21611 0ustar00etherstaff000000000000Moose-2.1005/t/type_constraints#!/usr/bin/perl use strict; use warnings; use Test::More; use Test::Fatal; use Scalar::Util qw(refaddr); use Moose::Util::TypeConstraints; # subtype 'aliasing' ... is( exception { subtype 'Numb3rs' => as 'Num'; }, undef, '... create bare subtype fine' ); my $numb3rs = find_type_constraint('Numb3rs'); isa_ok($numb3rs, 'Moose::Meta::TypeConstraint'); # subtype with unions { package Test::Moose::Meta::TypeConstraint::Union; use overload '""' => sub {'Broken|Test'}, fallback => 1; use Moose; extends 'Moose::Meta::TypeConstraint'; } my $dummy_instance = Test::Moose::Meta::TypeConstraint::Union->new; ok $dummy_instance => "Created Instance"; isa_ok $dummy_instance, 'Test::Moose::Meta::TypeConstraint::Union' => 'isa correct type'; is "$dummy_instance", "Broken|Test" => 'Got expected stringification result'; my $subtype1 = subtype 'New1' => as $dummy_instance; ok $subtype1 => 'made a subtype from our type object'; my $subtype2 = subtype 'New2' => as $subtype1; ok $subtype2 => 'made a subtype of our subtype'; # assert_valid { my $type = find_type_constraint('Num'); my $ok_1 = eval { $type->assert_valid(1); }; ok($ok_1, "we can assert_valid that 1 is of type $type"); my $ok_2 = eval { $type->assert_valid('foo'); }; my $error = $@; ok(! $ok_2, "'foo' is not of type $type"); like( $error, qr{validation failed for .\Q$type\E.}i, "correct error thrown" ); } { for my $t (qw(Bar Foo)) { my $tc = Moose::Meta::TypeConstraint->new({ name => $t, }); Moose::Util::TypeConstraints::register_type_constraint($tc); } my $foo = Moose::Util::TypeConstraints::find_type_constraint('Foo'); my $bar = Moose::Util::TypeConstraints::find_type_constraint('Bar'); ok(!$foo->equals($bar), "Foo type is not equal to Bar type"); ok( $foo->equals($foo), "Foo equals Foo"); ok( 0+$foo == refaddr($foo), "overloading works"); } ok $subtype1, "type constraint boolean overload works"; done_testing; types_and_undef.t100644000767000024 1140012200352345 21560 0ustar00etherstaff000000000000Moose-2.1005/t/type_constraints#!/usr/bin/perl use strict; use warnings; use Test::More; use Test::Fatal; { package Foo; use Moose; use Moose::Util::TypeConstraints; use Scalar::Util (); type Number => where { defined($_) && !ref($_) && Scalar::Util::looks_like_number($_) }; type String => where { defined($_) && !ref($_) && !Scalar::Util::looks_like_number($_) }; has vUndef => ( is => 'rw', isa => 'Undef' ); has vDefined => ( is => 'rw', isa => 'Defined' ); has vInt => ( is => 'rw', isa => 'Int' ); has vNumber => ( is => 'rw', isa => 'Number' ); has vStr => ( is => 'rw', isa => 'Str' ); has vString => ( is => 'rw', isa => 'String' ); has v_lazy_Undef => ( is => 'rw', lazy => 1, default => sub { undef }, isa => 'Undef' ); has v_lazy_Defined => ( is => 'rw', lazy => 1, default => sub { undef }, isa => 'Defined' ); has v_lazy_Int => ( is => 'rw', lazy => 1, default => sub { undef }, isa => 'Int' ); has v_lazy_Number => ( is => 'rw', lazy => 1, default => sub { undef }, isa => 'Number' ); has v_lazy_Str => ( is => 'rw', lazy => 1, default => sub { undef }, isa => 'Str' ); has v_lazy_String => ( is => 'rw', lazy => 1, default => sub { undef }, isa => 'String' ); } # EXPORT TYPE CONSTRAINTS # Moose::Util::TypeConstraints->export_type_constraints_as_functions; ok( Undef(undef), '... undef is a Undef'); ok(!Defined(undef), '... undef is NOT a Defined'); ok(!Int(undef), '... undef is NOT an Int'); ok(!Number(undef), '... undef is NOT a Number'); ok(!Str(undef), '... undef is NOT a Str'); ok(!String(undef), '... undef is NOT a String'); ok(!Undef(5), '... 5 is a NOT a Undef'); ok(Defined(5), '... 5 is a Defined'); ok(Int(5), '... 5 is an Int'); ok(Number(5), '... 5 is a Number'); ok(Str(5), '... 5 is a Str'); ok(!String(5), '... 5 is NOT a String'); ok(!Undef(0.5), '... 0.5 is a NOT a Undef'); ok(Defined(0.5), '... 0.5 is a Defined'); ok(!Int(0.5), '... 0.5 is NOT an Int'); ok(Number(0.5), '... 0.5 is a Number'); ok(Str(0.5), '... 0.5 is a Str'); ok(!String(0.5), '... 0.5 is NOT a String'); ok(!Undef('Foo'), '... "Foo" is NOT a Undef'); ok(Defined('Foo'), '... "Foo" is a Defined'); ok(!Int('Foo'), '... "Foo" is NOT an Int'); ok(!Number('Foo'), '... "Foo" is NOT a Number'); ok(Str('Foo'), '... "Foo" is a Str'); ok(String('Foo'), '... "Foo" is a String'); my $foo = Foo->new; is( exception { $foo->vUndef(undef) }, undef, '... undef is a Foo->Undef' ); isnt( exception { $foo->vDefined(undef) }, undef, '... undef is NOT a Foo->Defined' ); isnt( exception { $foo->vInt(undef) }, undef, '... undef is NOT a Foo->Int' ); isnt( exception { $foo->vNumber(undef) }, undef, '... undef is NOT a Foo->Number' ); isnt( exception { $foo->vStr(undef) }, undef, '... undef is NOT a Foo->Str' ); isnt( exception { $foo->vString(undef) }, undef, '... undef is NOT a Foo->String' ); isnt( exception { $foo->vUndef(5) }, undef, '... 5 is NOT a Foo->Undef' ); is( exception { $foo->vDefined(5) }, undef, '... 5 is a Foo->Defined' ); is( exception { $foo->vInt(5) }, undef, '... 5 is a Foo->Int' ); is( exception { $foo->vNumber(5) }, undef, '... 5 is a Foo->Number' ); is( exception { $foo->vStr(5) }, undef, '... 5 is a Foo->Str' ); isnt( exception { $foo->vString(5) }, undef, '... 5 is NOT a Foo->String' ); isnt( exception { $foo->vUndef(0.5) }, undef, '... 0.5 is NOT a Foo->Undef' ); is( exception { $foo->vDefined(0.5) }, undef, '... 0.5 is a Foo->Defined' ); isnt( exception { $foo->vInt(0.5) }, undef, '... 0.5 is NOT a Foo->Int' ); is( exception { $foo->vNumber(0.5) }, undef, '... 0.5 is a Foo->Number' ); is( exception { $foo->vStr(0.5) }, undef, '... 0.5 is a Foo->Str' ); isnt( exception { $foo->vString(0.5) }, undef, '... 0.5 is NOT a Foo->String' ); isnt( exception { $foo->vUndef('Foo') }, undef, '... "Foo" is NOT a Foo->Undef' ); is( exception { $foo->vDefined('Foo') }, undef, '... "Foo" is a Foo->Defined' ); isnt( exception { $foo->vInt('Foo') }, undef, '... "Foo" is NOT a Foo->Int' ); isnt( exception { $foo->vNumber('Foo') }, undef, '... "Foo" is NOT a Foo->Number' ); is( exception { $foo->vStr('Foo') }, undef, '... "Foo" is a Foo->Str' ); is( exception { $foo->vString('Foo') }, undef, '... "Foo" is a Foo->String' ); # the lazy tests is( exception { $foo->v_lazy_Undef() }, undef, '... undef is a Foo->Undef' ); isnt( exception { $foo->v_lazy_Defined() }, undef, '... undef is NOT a Foo->Defined' ); isnt( exception { $foo->v_lazy_Int() }, undef, '... undef is NOT a Foo->Int' ); isnt( exception { $foo->v_lazy_Number() }, undef, '... undef is NOT a Foo->Number' ); isnt( exception { $foo->v_lazy_Str() }, undef, '... undef is NOT a Foo->Str' ); isnt( exception { $foo->v_lazy_String() }, undef, '... undef is NOT a Foo->String' ); done_testing; Accessor.pm100644000767000024 133212200352345 21274 0ustar00etherstaff000000000000Moose-2.1005/benchmarks/cmop/lib/Bench#!/usr/bin/perl package Bench::Accessor; use Moose; use Moose::Util::TypeConstraints; eval { coerce ArrayRef => from HashRef => via { [ %$_ ] }; }; has class => ( isa => "Str", is => "ro", ); has construct => ( isa => "ArrayRef", is => "ro", auto_deref => 1, coerce => 1, ); has accessor => ( isa => "Str", is => "ro", ); has accessor_args => ( isa => "ArrayRef", is => "ro", auto_deref => 1, coerce => 1, ); sub code { my $self = shift; my $obj = $self->class->new( $self->construct ); my @accessor_args = $self->accessor_args; my $accessor = $self->accessor; sub { $obj->$accessor( @accessor_args ) }; } __PACKAGE__; __END__ Keywords.pod100644000767000024 715412200352345 21314 0ustar00etherstaff000000000000Moose-2.1005/lib/Moose/Cookbook/Snackpackage Moose::Cookbook::Snack::Keywords; # ABSTRACT: Restricted "keywords" in Moose __END__ =pod =head1 NAME Moose::Cookbook::Snack::Keywords - Restricted "keywords" in Moose =head1 VERSION version 2.1005 =head1 DESCRIPTION Moose exports a number of sugar functions in order to emulate Perl built-in keywords. These can cause clashes with other user-defined functions. This document provides a list of those keywords for easy reference. =head2 The 'meta' keyword C> adds a method called C to your class. If this conflicts with a method or function you are using, you can rename it, or prevent it from being installed entirely. To do this, pass the C<-meta_name> option when you C>. For instance: # install it under a different name use Moose -meta_name => 'moose_meta'; # don't install it at all use Moose -meta_name => undef; =head2 Moose Keywords If you are using L or L it is best to avoid these keywords: =over 4 =item extends =item with =item has =item before =item after =item around =item super =item override =item inner =item augment =item confess =item blessed =back =head2 Moose::Util::TypeConstraints Keywords If you are using L it is best to avoid these keywords: =over 4 =item type =item subtype =item class_type =item role_type =item maybe_type =item duck_type =item as =item where =item message =item optimize_as =item inline_as =item coerce =item from =item via =item enum =item find_type_constraint =item register_type_constraint =back =head2 Avoiding collisions =head3 Turning off Moose To remove the sugar functions L exports, just add C> at the bottom of your code: package Thing; use Moose; # code here no Moose; This will unexport the sugar functions that L originally exported. The same will also work for L and L. =head3 Sub::Exporter features L, L and L all use L to handle all their exporting needs. This means that all the features that L provides are also available to them. For instance, with L you can rename keywords, like so: package LOL::Cat; use Moose 'has' => { -as => 'i_can_haz' }; i_can_haz 'cheeseburger' => ( is => 'rw', trigger => sub { print "NOM NOM" } ); LOL::Cat->new->cheeseburger('KTHNXBYE'); See the L docs for more information. =head3 namespace::autoclean and namespace::clean You can also use L to clean up your namespace. This will remove all imported functions from your namespace. Note that if you are importing functions that are intended to be used as methods (this includes L, due to internal implementation details), it will remove these as well. Another option is to use L directly, but you must be careful not to remove C when doing so: package Foo; use Moose; use namespace::clean -except => 'meta'; # ... =head1 SEE ALSO =over 4 =item L =item L =item L =item L =item L =item L =back =head1 AUTHOR Moose is maintained by the Moose Cabal, along with the help of many contributors. See L and L for details. =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2013 by Infinity Interactive, Inc.. This is free software; you can redistribute it and/or modify it under the same terms as the Perl 5 programming language system itself. =cut Mixin000755000767000024 012200352345 15777 5ustar00etherstaff000000000000Moose-2.1005/lib/Moose/MetaAttributeCore.pm100644000767000024 606112200352345 21254 0ustar00etherstaff000000000000Moose-2.1005/lib/Moose/Meta/Mixinpackage Moose::Meta::Mixin::AttributeCore; BEGIN { $Moose::Meta::Mixin::AttributeCore::AUTHORITY = 'cpan:STEVAN'; } { $Moose::Meta::Mixin::AttributeCore::VERSION = '2.1005'; } use strict; use warnings; use base 'Class::MOP::Mixin::AttributeCore'; __PACKAGE__->meta->add_attribute( 'isa' => ( reader => '_isa_metadata', Class::MOP::_definition_context(), ) ); __PACKAGE__->meta->add_attribute( 'does' => ( reader => '_does_metadata', Class::MOP::_definition_context(), ) ); __PACKAGE__->meta->add_attribute( 'is' => ( reader => '_is_metadata', Class::MOP::_definition_context(), ) ); __PACKAGE__->meta->add_attribute( 'required' => ( reader => 'is_required', Class::MOP::_definition_context(), ) ); __PACKAGE__->meta->add_attribute( 'lazy' => ( reader => 'is_lazy', Class::MOP::_definition_context(), ) ); __PACKAGE__->meta->add_attribute( 'lazy_build' => ( reader => 'is_lazy_build', Class::MOP::_definition_context(), ) ); __PACKAGE__->meta->add_attribute( 'coerce' => ( reader => 'should_coerce', Class::MOP::_definition_context(), ) ); __PACKAGE__->meta->add_attribute( 'weak_ref' => ( reader => 'is_weak_ref', Class::MOP::_definition_context(), ) ); __PACKAGE__->meta->add_attribute( 'auto_deref' => ( reader => 'should_auto_deref', Class::MOP::_definition_context(), ) ); __PACKAGE__->meta->add_attribute( 'type_constraint' => ( reader => 'type_constraint', predicate => 'has_type_constraint', Class::MOP::_definition_context(), ) ); __PACKAGE__->meta->add_attribute( 'trigger' => ( reader => 'trigger', predicate => 'has_trigger', Class::MOP::_definition_context(), ) ); __PACKAGE__->meta->add_attribute( 'handles' => ( reader => 'handles', writer => '_set_handles', predicate => 'has_handles', Class::MOP::_definition_context(), ) ); __PACKAGE__->meta->add_attribute( 'documentation' => ( reader => 'documentation', predicate => 'has_documentation', Class::MOP::_definition_context(), ) ); 1; # ABSTRACT: Core attributes shared by attribute metaclasses __END__ =pod =head1 NAME Moose::Meta::Mixin::AttributeCore - Core attributes shared by attribute metaclasses =head1 VERSION version 2.1005 =head1 DESCRIPTION This class implements the core attributes (aka properties) shared by all Moose attributes. See the L documentation for API details. =head1 BUGS See L for details on reporting bugs. =head1 AUTHOR Moose is maintained by the Moose Cabal, along with the help of many contributors. See L and L for details. =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2013 by Infinity Interactive, Inc.. This is free software; you can redistribute it and/or modify it under the same terms as the Perl 5 programming language system itself. =cut TypeConstraint000755000767000024 012200352345 17701 5ustar00etherstaff000000000000Moose-2.1005/lib/Moose/MetaEnum.pm100644000767000024 1041312200352345 21322 0ustar00etherstaff000000000000Moose-2.1005/lib/Moose/Meta/TypeConstraintpackage Moose::Meta::TypeConstraint::Enum; BEGIN { $Moose::Meta::TypeConstraint::Enum::AUTHORITY = 'cpan:STEVAN'; } { $Moose::Meta::TypeConstraint::Enum::VERSION = '2.1005'; } use strict; use warnings; use metaclass; use B; use Moose::Util::TypeConstraints (); use base 'Moose::Meta::TypeConstraint'; __PACKAGE__->meta->add_attribute('values' => ( accessor => 'values', Class::MOP::_definition_context(), )); __PACKAGE__->meta->add_attribute('_inline_var_name' => ( accessor => '_inline_var_name', Class::MOP::_definition_context(), )); my $inliner = sub { my $self = shift; my $val = shift; return 'defined(' . $val . ') ' . '&& !ref(' . $val . ') ' . '&& $' . $self->_inline_var_name . '{' . $val . '}'; }; my $var_suffix = 0; sub new { my ( $class, %args ) = @_; $args{parent} = Moose::Util::TypeConstraints::find_type_constraint('Str'); $args{inlined} = $inliner; if ( scalar @{ $args{values} } < 1 ) { require Moose; Moose->throw_error("You must have at least one value to enumerate through"); } for (@{ $args{values} }) { if (!defined($_)) { require Moose; Moose->throw_error("Enum values must be strings, not undef"); } elsif (ref($_)) { require Moose; Moose->throw_error("Enum values must be strings, not '$_'"); } } my %values = map { $_ => 1 } @{ $args{values} }; $args{constraint} = sub { $values{ $_[0] } }; my $var_name = 'enums' . $var_suffix++;; $args{_inline_var_name} = $var_name; $args{inline_environment} = { '%' . $var_name => \%values }; my $self = $class->SUPER::new(\%args); $self->compile_type_constraint() unless $self->_has_compiled_type_constraint; return $self; } sub equals { my ( $self, $type_or_name ) = @_; my $other = Moose::Util::TypeConstraints::find_type_constraint($type_or_name); return unless $other->isa(__PACKAGE__); my @self_values = sort @{ $self->values }; my @other_values = sort @{ $other->values }; return unless @self_values == @other_values; while ( @self_values ) { my $value = shift @self_values; my $other_value = shift @other_values; return unless $value eq $other_value; } return 1; } sub constraint { my $self = shift; my %values = map { $_ => undef } @{ $self->values }; return sub { exists $values{$_[0]} }; } sub create_child_type { my ($self, @args) = @_; return Moose::Meta::TypeConstraint->new(@args, parent => $self); } 1; # ABSTRACT: Type constraint for enumerated values. __END__ =pod =head1 NAME Moose::Meta::TypeConstraint::Enum - Type constraint for enumerated values. =head1 VERSION version 2.1005 =head1 DESCRIPTION This class represents type constraints based on an enumerated list of acceptable values. =head1 INHERITANCE C is a subclass of L. =head1 METHODS =over 4 =item B<< Moose::Meta::TypeConstraint::Enum->new(%options) >> This creates a new enum type constraint based on the given C<%options>. It takes the same options as its parent, with several exceptions. First, it requires an additional option, C. This should be an array reference containing a list of valid string values. Second, it automatically sets the parent to the C type. Finally, it ignores any provided C option. The constraint is generated automatically based on the provided C. =item B<< $constraint->values >> Returns the array reference of acceptable values provided to the constructor. =item B<< $constraint->create_child_type >> This returns a new L object with the type as its parent. Note that it does I return a C object! =back =head1 BUGS See L for details on reporting bugs. =head1 AUTHOR Moose is maintained by the Moose Cabal, along with the help of many contributors. See L and L for details. =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2013 by Infinity Interactive, Inc.. This is free software; you can redistribute it and/or modify it under the same terms as the Perl 5 programming language system itself. =cut Role.pm100644000767000024 1251112200352345 21320 0ustar00etherstaff000000000000Moose-2.1005/lib/Moose/Meta/TypeConstraintpackage Moose::Meta::TypeConstraint::Role; BEGIN { $Moose::Meta::TypeConstraint::Role::AUTHORITY = 'cpan:STEVAN'; } { $Moose::Meta::TypeConstraint::Role::VERSION = '2.1005'; } use strict; use warnings; use metaclass; use B; use Scalar::Util 'blessed'; use Moose::Util::TypeConstraints (); use base 'Moose::Meta::TypeConstraint'; __PACKAGE__->meta->add_attribute('role' => ( reader => 'role', Class::MOP::_definition_context(), )); my $inliner = sub { my $self = shift; my $val = shift; return 'Moose::Util::does_role(' . $val . ', ' . B::perlstring($self->role) . ')'; }; sub new { my ( $class, %args ) = @_; $args{parent} = Moose::Util::TypeConstraints::find_type_constraint('Object'); my $role_name = $args{role}; $args{constraint} = sub { Moose::Util::does_role( $_[0], $role_name ) }; $args{inlined} = $inliner; my $self = $class->SUPER::new( \%args ); $self->_create_hand_optimized_type_constraint; $self->compile_type_constraint(); return $self; } sub _create_hand_optimized_type_constraint { my $self = shift; my $role = $self->role; $self->hand_optimized_type_constraint( sub { Moose::Util::does_role($_[0], $role) } ); } sub parents { my $self = shift; return ( $self->parent, map { # FIXME find_type_constraint might find a TC named after the role but that isn't really it # I did this anyway since it's a convention that preceded TypeConstraint::Role, and it should DWIM # if anybody thinks this problematic please discuss on IRC. # a possible fix is to add by attr indexing to the type registry to find types of a certain property # regardless of their name Moose::Util::TypeConstraints::find_type_constraint($_) || __PACKAGE__->new( role => $_, name => "__ANON__" ) } @{ Class::MOP::class_of($self->role)->get_roles }, ); } sub equals { my ( $self, $type_or_name ) = @_; my $other = Moose::Util::TypeConstraints::find_type_constraint($type_or_name); return unless defined $other; return unless $other->isa(__PACKAGE__); return $self->role eq $other->role; } sub is_a_type_of { my ($self, $type_or_name) = @_; my $type = Moose::Util::TypeConstraints::find_type_constraint($type_or_name); ($self->equals($type) || $self->is_subtype_of($type_or_name)); } sub is_subtype_of { my ($self, $type_or_name_or_role ) = @_; if ( not ref $type_or_name_or_role ) { # it might be a role my $class = Class::MOP::class_of($self->role); return 1 if defined($class) && $class->does_role( $type_or_name_or_role ); } my $type = Moose::Util::TypeConstraints::find_type_constraint($type_or_name_or_role); return unless defined $type; if ( $type->isa(__PACKAGE__) ) { # if $type_or_name_or_role isn't a role, it might be the TC name of another ::Role type # or it could also just be a type object in this branch my $class = Class::MOP::class_of($self->role); return defined($class) && $class->does_role( $type->role ); } else { # the only other thing we are a subtype of is Object $self->SUPER::is_subtype_of($type); } } sub create_child_type { my ($self, @args) = @_; return Moose::Meta::TypeConstraint->new(@args, parent => $self); } 1; # ABSTRACT: Role/TypeConstraint parallel hierarchy __END__ =pod =head1 NAME Moose::Meta::TypeConstraint::Role - Role/TypeConstraint parallel hierarchy =head1 VERSION version 2.1005 =head1 DESCRIPTION This class represents type constraints for a role. =head1 INHERITANCE C is a subclass of L. =head1 METHODS =over 4 =item B<< Moose::Meta::TypeConstraint::Role->new(%options) >> This creates a new role type constraint based on the given C<%options>. It takes the same options as its parent, with two exceptions. First, it requires an additional option, C, which is name of the constraint's role. Second, it automatically sets the parent to the C type. The constructor also overrides the hand optimized type constraint with one it creates internally. =item B<< $constraint->role >> Returns the role name associated with the constraint. =item B<< $constraint->parents >> Returns all the type's parent types, corresponding to the roles that its role does. =item B<< $constraint->is_subtype_of($type_name_or_object) >> If the given type is also a role type, then this checks that the type's role does the other type's role. Otherwise it falls back to the implementation in L. =item B<< $constraint->create_child_type(%options) >> This returns a new L object with the type as its parent. Note that it does I return a C object! =back =head1 BUGS See L for details on reporting bugs. =head1 AUTHOR Moose is maintained by the Moose Cabal, along with the help of many contributors. See L and L for details. =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2013 by Infinity Interactive, Inc.. This is free software; you can redistribute it and/or modify it under the same terms as the Perl 5 programming language system itself. =cut global-destruction-helper.pl100644000767000024 61312200352345 21437 0ustar00etherstaff000000000000Moose-2.1005/t/basics#!/usr/bin/perl use strict; use warnings; { package Foo; use Moose; sub DEMOLISH { my $self = shift; my ($igd) = @_; print $igd; } } { package Bar; use Moose; sub DEMOLISH { my $self = shift; my ($igd) = @_; print $igd; } __PACKAGE__->meta->make_immutable; } our $foo = Foo->new; our $bar = Bar->new; immutable_w_custom_metaclass.t100644000767000024 355212200352345 21663 0ustar00etherstaff000000000000Moose-2.1005/t/cmopuse strict; use warnings; use FindBin; use File::Spec::Functions; use Test::More; use Test::Fatal; use Scalar::Util; use Class::MOP; use lib catdir( $FindBin::Bin, 'lib' ); { package Foo; use strict; use warnings; use metaclass; __PACKAGE__->meta->make_immutable; package Bar; use strict; use warnings; use metaclass; __PACKAGE__->meta->make_immutable; package Baz; use strict; use warnings; use metaclass 'MyMetaClass'; sub mymetaclass_attributes { shift->meta->mymetaclass_attributes; } ::is( ::exception { Baz->meta->superclasses('Bar') }, undef, '... we survive the metaclass incompatibility test' ); } { my $meta = Baz->meta; ok( $meta->is_mutable, '... Baz is mutable' ); is( Scalar::Util::blessed( Foo->meta ), Scalar::Util::blessed( Bar->meta ), 'Foo and Bar immutable metaclasses match' ); is( Scalar::Util::blessed($meta), 'MyMetaClass', 'Baz->meta blessed as MyMetaClass' ); ok( Baz->can('mymetaclass_attributes'), '... Baz can do method before immutable' ); ok( $meta->can('mymetaclass_attributes'), '... meta can do method before immutable' ); is( exception { $meta->make_immutable }, undef, "Baz is now immutable" ); ok( $meta->is_immutable, '... Baz is immutable' ); isa_ok( $meta, 'MyMetaClass', 'Baz->meta' ); ok( Baz->can('mymetaclass_attributes'), '... Baz can do method after imutable' ); ok( $meta->can('mymetaclass_attributes'), '... meta can do method after immutable' ); isnt( Scalar::Util::blessed( Baz->meta ), Scalar::Util::blessed( Bar->meta ), 'Baz and Bar immutable metaclasses are different' ); is( exception { $meta->make_mutable }, undef, "Baz is now mutable" ); ok( $meta->is_mutable, '... Baz is mutable again' ); } done_testing; export_with_prototype.t100644000767000024 102112200352345 21764 0ustar00etherstaff000000000000Moose-2.1005/t/metaclassesuse lib "t/lib"; package MyExporter::User; use MyExporter; use Test::More; use Test::Fatal; is( exception { with_prototype { my $caller = caller(0); is($caller, 'MyExporter', "With_caller prototype code gets called from MyMooseX"); }; }, undef, "check function with prototype" ); is( exception { as_is_prototype { my $caller = caller(0); is($caller, 'MyExporter', "As-is prototype code gets called from MyMooseX"); }; }, undef, "check function with prototype" ); done_testing; role_composition_attributes.t100644000767000024 423212200352345 21744 0ustar00etherstaff000000000000Moose-2.1005/t/roles#!/usr/bin/perl use strict; use warnings; use Test::More; use Test::Fatal; use Moose::Meta::Role::Application::RoleSummation; use Moose::Meta::Role::Composite; { package Role::Foo; use Moose::Role; has 'foo' => (is => 'rw'); package Role::Bar; use Moose::Role; has 'bar' => (is => 'rw'); package Role::FooConflict; use Moose::Role; has 'foo' => (is => 'rw'); package Role::BarConflict; use Moose::Role; has 'bar' => (is => 'rw'); package Role::AnotherFooConflict; use Moose::Role; with 'Role::FooConflict'; } # test simple attributes { my $c = Moose::Meta::Role::Composite->new( roles => [ Role::Foo->meta, Role::Bar->meta, ] ); isa_ok($c, 'Moose::Meta::Role::Composite'); is($c->name, 'Role::Foo|Role::Bar', '... got the composite role name'); is( exception { Moose::Meta::Role::Application::RoleSummation->new->apply($c); }, undef, '... this succeeds as expected' ); is_deeply( [ sort $c->get_attribute_list ], [ 'bar', 'foo' ], '... got the right list of attributes' ); } # test simple conflict isnt( exception { Moose::Meta::Role::Application::RoleSummation->new->apply( Moose::Meta::Role::Composite->new( roles => [ Role::Foo->meta, Role::FooConflict->meta, ] ) ); }, undef, '... this fails as expected' ); # test complex conflict isnt( exception { Moose::Meta::Role::Application::RoleSummation->new->apply( Moose::Meta::Role::Composite->new( roles => [ Role::Foo->meta, Role::Bar->meta, Role::FooConflict->meta, Role::BarConflict->meta, ] ) ); }, undef, '... this fails as expected' ); # test simple conflict isnt( exception { Moose::Meta::Role::Application::RoleSummation->new->apply( Moose::Meta::Role::Composite->new( roles => [ Role::Foo->meta, Role::AnotherFooConflict->meta, ] ) ); }, undef, '... this fails as expected' ); done_testing; meta_table_metaclasstrait.t100644000767000024 143612200352345 21620 0ustar00etherstaff000000000000Moose-2.1005/t/recipes#!/usr/bin/perl -w use strict; use Test::More 'no_plan'; use Test::Fatal; $| = 1; # =begin testing SETUP BEGIN { package MyApp::Meta::Class::Trait::HasTable; use Moose::Role; Moose::Util::meta_class_alias('HasTable'); has table => ( is => 'rw', isa => 'Str', ); } # =begin testing SETUP { # in lib/MyApp/Meta/Class/Trait/HasTable.pm package MyApp::Meta::Class::Trait::HasTable; use Moose::Role; Moose::Util::meta_class_alias('HasTable'); has table => ( is => 'rw', isa => 'Str', ); # in lib/MyApp/User.pm package MyApp::User; use Moose -traits => 'HasTable'; __PACKAGE__->meta->table('User'); } # =begin testing { can_ok( MyApp::User->meta, 'table' ); is( MyApp::User->meta->table, 'User', 'My::User table is User' ); } 1; Construct.pm100644000767000024 74012200352345 21500 0ustar00etherstaff000000000000Moose-2.1005/benchmarks/cmop/lib/Bench#!/usr/bin/perl package Bench::Construct; use Moose; use Moose::Util::TypeConstraints; has class => ( isa => "Str", is => "ro", ); eval { coerce ArrayRef => from HashRef => via { [ %$_ ] }; }; has args => ( isa => "ArrayRef", is => "ro", auto_deref => 1, coerce => 1, ); sub code { my $self = shift; my $class = $self->class; my @args = $self->args; sub { my $obj = $class->new( @args ) } } __PACKAGE__; __END__ Immutable000755000767000024 012200352345 17427 5ustar00etherstaff000000000000Moose-2.1005/lib/Class/MOP/ClassTrait.pm100644000767000024 571212200352345 21215 0ustar00etherstaff000000000000Moose-2.1005/lib/Class/MOP/Class/Immutablepackage Class::MOP::Class::Immutable::Trait; BEGIN { $Class::MOP::Class::Immutable::Trait::AUTHORITY = 'cpan:STEVAN'; } { $Class::MOP::Class::Immutable::Trait::VERSION = '2.1005'; } use strict; use warnings; use MRO::Compat; use Carp 'confess'; use Scalar::Util 'blessed', 'weaken'; # the original class of the metaclass instance sub _get_mutable_metaclass_name { $_[0]{__immutable}{original_class} } sub is_mutable { 0 } sub is_immutable { 1 } sub _immutable_metaclass { ref $_[1] } sub _immutable_read_only { my $name = shift; confess "The '$name' method is read-only when called on an immutable instance"; } sub _immutable_cannot_call { my $name = shift; Carp::confess "The '$name' method cannot be called on an immutable instance"; } for my $name (qw/superclasses/) { no strict 'refs'; *{__PACKAGE__."::$name"} = sub { my $orig = shift; my $self = shift; _immutable_read_only($name) if @_; $self->$orig; }; } for my $name (qw/add_method alias_method remove_method add_attribute remove_attribute remove_package_symbol add_package_symbol/) { no strict 'refs'; *{__PACKAGE__."::$name"} = sub { _immutable_cannot_call($name) }; } sub class_precedence_list { my $orig = shift; my $self = shift; @{ $self->{__immutable}{class_precedence_list} ||= [ $self->$orig ] }; } sub linearized_isa { my $orig = shift; my $self = shift; @{ $self->{__immutable}{linearized_isa} ||= [ $self->$orig ] }; } sub get_all_methods { my $orig = shift; my $self = shift; @{ $self->{__immutable}{get_all_methods} ||= [ $self->$orig ] }; } sub get_all_method_names { my $orig = shift; my $self = shift; @{ $self->{__immutable}{get_all_method_names} ||= [ $self->$orig ] }; } sub get_all_attributes { my $orig = shift; my $self = shift; @{ $self->{__immutable}{get_all_attributes} ||= [ $self->$orig ] }; } sub get_meta_instance { my $orig = shift; my $self = shift; $self->{__immutable}{get_meta_instance} ||= $self->$orig; } sub _method_map { my $orig = shift; my $self = shift; $self->{__immutable}{_method_map} ||= $self->$orig; } 1; # ABSTRACT: Implements immutability for metaclass objects __END__ =pod =head1 NAME Class::MOP::Class::Immutable::Trait - Implements immutability for metaclass objects =head1 VERSION version 2.1005 =head1 DESCRIPTION This class provides a pseudo-trait that is applied to immutable metaclass objects. In reality, it is simply a parent class. It implements caching and read-only-ness for various metaclass methods. =head1 AUTHOR Moose is maintained by the Moose Cabal, along with the help of many contributors. See L and L for details. =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2013 by Infinity Interactive, Inc.. This is free software; you can redistribute it and/or modify it under the same terms as the Perl 5 programming language system itself. =cut Method000755000767000024 012200352345 17034 5ustar00etherstaff000000000000Moose-2.1005/lib/Moose/Meta/RoleRequired.pm100644000767000024 350612200352345 21316 0ustar00etherstaff000000000000Moose-2.1005/lib/Moose/Meta/Role/Method package Moose::Meta::Role::Method::Required; BEGIN { $Moose::Meta::Role::Method::Required::AUTHORITY = 'cpan:STEVAN'; } { $Moose::Meta::Role::Method::Required::VERSION = '2.1005'; } use strict; use warnings; use metaclass; use overload '""' => sub { shift->name }, # stringify to method name fallback => 1; use base qw(Class::MOP::Object); # This is not a Moose::Meta::Role::Method because it has no implementation, it # is just a name __PACKAGE__->meta->add_attribute('name' => ( reader => 'name', required => 1, Class::MOP::_definition_context(), )); sub new { shift->_new(@_) } 1; # ABSTRACT: A Moose metaclass for required methods in Roles __END__ =pod =head1 NAME Moose::Meta::Role::Method::Required - A Moose metaclass for required methods in Roles =head1 VERSION version 2.1005 =head1 DESCRIPTION =head1 INHERITANCE C is a subclass of L. It is B a subclass of C since it does not provide an implementation of the method. =head1 METHODS =over 4 =item B<< Moose::Meta::Role::Method::Required->new(%options) >> This creates a new type constraint based on the provided C<%options>: =over 8 =item * name The method name. This is required. =back =item B<< $method->name >> Returns the required method's name, as provided to the constructor. =back =head1 BUGS See L for details on reporting bugs. =head1 AUTHOR Moose is maintained by the Moose Cabal, along with the help of many contributors. See L and L for details. =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2013 by Infinity Interactive, Inc.. This is free software; you can redistribute it and/or modify it under the same terms as the Perl 5 programming language system itself. =cut Class.pm100644000767000024 1372012200352345 21467 0ustar00etherstaff000000000000Moose-2.1005/lib/Moose/Meta/TypeConstraintpackage Moose::Meta::TypeConstraint::Class; BEGIN { $Moose::Meta::TypeConstraint::Class::AUTHORITY = 'cpan:STEVAN'; } { $Moose::Meta::TypeConstraint::Class::VERSION = '2.1005'; } use strict; use warnings; use metaclass; use B; use Scalar::Util 'blessed'; use Moose::Util::TypeConstraints (); use base 'Moose::Meta::TypeConstraint'; __PACKAGE__->meta->add_attribute('class' => ( reader => 'class', Class::MOP::_definition_context(), )); my $inliner = sub { my $self = shift; my $val = shift; return 'Scalar::Util::blessed(' . $val . ')' . ' && ' . $val . '->isa(' . B::perlstring($self->class) . ')'; }; sub new { my ( $class, %args ) = @_; $args{parent} = Moose::Util::TypeConstraints::find_type_constraint('Object'); my $class_name = $args{class}; $args{constraint} = sub { $_[0]->isa($class_name) }; $args{inlined} = $inliner; my $self = $class->SUPER::new( \%args ); $self->compile_type_constraint(); return $self; } sub parents { my $self = shift; return ( $self->parent, map { # FIXME find_type_constraint might find a TC named after the class but that isn't really it # I did this anyway since it's a convention that preceded TypeConstraint::Class, and it should DWIM # if anybody thinks this problematic please discuss on IRC. # a possible fix is to add by attr indexing to the type registry to find types of a certain property # regardless of their name Moose::Util::TypeConstraints::find_type_constraint($_) || __PACKAGE__->new( class => $_, name => "__ANON__" ) } Class::MOP::class_of($self->class)->superclasses, ); } sub equals { my ( $self, $type_or_name ) = @_; my $other = Moose::Util::TypeConstraints::find_type_constraint($type_or_name); if (!defined($other)) { if (!ref($type_or_name)) { return $self->class eq $type_or_name; } return; } return unless $other->isa(__PACKAGE__); return $self->class eq $other->class; } sub is_a_type_of { my ($self, $type_or_name) = @_; ($self->equals($type_or_name) || $self->is_subtype_of($type_or_name)); } sub is_subtype_of { my ($self, $type_or_name_or_class ) = @_; my $type = Moose::Util::TypeConstraints::find_type_constraint($type_or_name_or_class); if ( not defined $type ) { if ( not ref $type_or_name_or_class ) { # it might be a class my $class = $self->class; return 1 if $class ne $type_or_name_or_class && $class->isa( $type_or_name_or_class ); } return; } if ( $type->isa(__PACKAGE__) && $type->class ne $self->class) { # if $type_or_name_or_class isn't a class, it might be the TC name of another ::Class type # or it could also just be a type object in this branch return $self->class->isa( $type->class ); } else { # the only other thing we are a subtype of is Object $self->SUPER::is_subtype_of($type); } } # This is a bit counter-intuitive, but a child type of a Class type # constraint is not itself a Class type constraint (it has no class # attribute). This whole create_child_type thing needs some changing # though, probably making MMC->new a factory or something. sub create_child_type { my ($self, @args) = @_; return Moose::Meta::TypeConstraint->new(@args, parent => $self); } sub get_message { my $self = shift; my ($value) = @_; if ($self->has_message) { return $self->SUPER::get_message(@_); } $value = (defined $value ? overload::StrVal($value) : 'undef'); return "Validation failed for '" . $self->name . "' with value $value (not isa " . $self->class . ")"; } 1; # ABSTRACT: Class/TypeConstraint parallel hierarchy __END__ =pod =head1 NAME Moose::Meta::TypeConstraint::Class - Class/TypeConstraint parallel hierarchy =head1 VERSION version 2.1005 =head1 DESCRIPTION This class represents type constraints for a class. =head1 INHERITANCE C is a subclass of L. =head1 METHODS =over 4 =item B<< Moose::Meta::TypeConstraint::Class->new(%options) >> This creates a new class type constraint based on the given C<%options>. It takes the same options as its parent, with two exceptions. First, it requires an additional option, C, which is name of the constraint's class. Second, it automatically sets the parent to the C type. The constructor also overrides the hand optimized type constraint with one it creates internally. =item B<< $constraint->class >> Returns the class name associated with the constraint. =item B<< $constraint->parents >> Returns all the type's parent types, corresponding to its parent classes. =item B<< $constraint->is_subtype_of($type_name_or_object) >> If the given type is also a class type, then this checks that the type's class is a subclass of the other type's class. Otherwise it falls back to the implementation in L. =item B<< $constraint->create_child_type(%options) >> This returns a new L object with the type as its parent. Note that it does I return a C object! =item B<< $constraint->get_message($value) >> This is the same as L except that it explicitly says C was checked. This is to help users deal with accidentally autovivified type constraints. =back =head1 BUGS See L for details on reporting bugs. =head1 AUTHOR Moose is maintained by the Moose Cabal, along with the help of many contributors. See L and L for details. =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2013 by Infinity Interactive, Inc.. This is free software; you can redistribute it and/or modify it under the same terms as the Perl 5 programming language system itself. =cut Union.pm100644000767000024 1753112200352345 21516 0ustar00etherstaff000000000000Moose-2.1005/lib/Moose/Meta/TypeConstraint package Moose::Meta::TypeConstraint::Union; BEGIN { $Moose::Meta::TypeConstraint::Union::AUTHORITY = 'cpan:STEVAN'; } { $Moose::Meta::TypeConstraint::Union::VERSION = '2.1005'; } use strict; use warnings; use metaclass; use Moose::Meta::TypeCoercion::Union; use List::MoreUtils qw(all); use List::Util qw(first); use base 'Moose::Meta::TypeConstraint'; __PACKAGE__->meta->add_attribute('type_constraints' => ( accessor => 'type_constraints', default => sub { [] }, Class::MOP::_definition_context(), )); sub new { my ($class, %options) = @_; my $name = join '|' => sort { $a cmp $b } map { $_->name } @{ $options{type_constraints} }; my $self = $class->SUPER::new( name => $name, %options, ); $self->_set_constraint( $self->_compiled_type_constraint ); return $self; } # XXX - this is a rather gross implementation of laziness for the benefit of # MX::Types. If we try to call ->has_coercion on the objects during object # construction, this does not work when defining a recursive constraint with # MX::Types. sub coercion { my $self = shift; return $self->{coercion} if exists $self->{coercion}; # Using any instead of grep here causes a weird error with some corner # cases when MX::Types is in use. See RT #61001. if ( grep { $_->has_coercion } @{ $self->type_constraints } ) { return $self->{coercion} = Moose::Meta::TypeCoercion::Union->new( type_constraint => $self ); } else { return $self->{coercion} = undef; } } sub has_coercion { return defined $_[0]->coercion; } sub _actually_compile_type_constraint { my $self = shift; my @constraints = @{ $self->type_constraints }; return sub { my $value = shift; foreach my $type (@constraints) { return 1 if $type->check($value); } return undef; }; } sub can_be_inlined { my $self = shift; # This was originally done with all() from List::MoreUtils, but that # caused some sort of bizarro parsing failure under 5.10. for my $tc ( @{ $self->type_constraints } ) { return 0 unless $tc->can_be_inlined; } return 1; } sub _inline_check { my $self = shift; my $val = shift; return '(' . ( join ' || ', map { '(' . $_->_inline_check($val) . ')' } @{ $self->type_constraints } ) . ')'; } sub inline_environment { my $self = shift; return { map { %{ $_->inline_environment } } @{ $self->type_constraints } }; } sub equals { my ( $self, $type_or_name ) = @_; my $other = Moose::Util::TypeConstraints::find_type_constraint($type_or_name); return unless $other->isa(__PACKAGE__); my @self_constraints = @{ $self->type_constraints }; my @other_constraints = @{ $other->type_constraints }; return unless @self_constraints == @other_constraints; # FIXME presort type constraints for efficiency? constraint: foreach my $constraint ( @self_constraints ) { for ( my $i = 0; $i < @other_constraints; $i++ ) { if ( $constraint->equals($other_constraints[$i]) ) { splice @other_constraints, $i, 1; next constraint; } } } return @other_constraints == 0; } sub parent { my $self = shift; my ($first, @rest) = @{ $self->type_constraints }; for my $parent ( $first->_collect_all_parents ) { return $parent if all { $_->is_a_type_of($parent) } @rest; } return; } sub validate { my ($self, $value) = @_; my $message; foreach my $type (@{$self->type_constraints}) { my $err = $type->validate($value); return unless defined $err; $message .= ($message ? ' and ' : '') . $err if defined $err; } return ($message . ' in (' . $self->name . ')') ; } sub find_type_for { my ($self, $value) = @_; return first { $_->check($value) } @{ $self->type_constraints }; } sub is_a_type_of { my ($self, $type_name) = @_; return all { $_->is_a_type_of($type_name) } @{ $self->type_constraints }; } sub is_subtype_of { my ($self, $type_name) = @_; return all { $_->is_subtype_of($type_name) } @{ $self->type_constraints }; } sub create_child_type { my ( $self, %opts ) = @_; my $constraint = Moose::Meta::TypeConstraint->new( %opts, parent => $self ); # if we have a type constraint union, and no # type check, this means we are just aliasing # the union constraint, which means we need to # handle this differently. # - SL if ( not( defined $opts{constraint} ) && $self->has_coercion ) { $constraint->coercion( Moose::Meta::TypeCoercion::Union->new( type_constraint => $self, ) ); } return $constraint; } 1; # ABSTRACT: A union of Moose type constraints __END__ =pod =head1 NAME Moose::Meta::TypeConstraint::Union - A union of Moose type constraints =head1 VERSION version 2.1005 =head1 DESCRIPTION This metaclass represents a union of type constraints. A union takes multiple type constraints, and is true if any one of its member constraints is true. =head1 INHERITANCE C is a subclass of L. =over 4 =item B<< Moose::Meta::TypeConstraint::Union->new(%options) >> This creates a new class type constraint based on the given C<%options>. It takes the same options as its parent. It also requires an additional option, C. This is an array reference containing the L objects that are the members of the union type. The C option defaults to the names all of these member types sorted and then joined by a pipe (|). The constructor sets the implementation of the constraint so that is simply calls C on the newly created object. Finally, the constructor also makes sure that the object's C attribute is a L object. =item B<< $constraint->type_constraints >> This returns the array reference of C provided to the constructor. =item B<< $constraint->parent >> This returns the nearest common ancestor of all the components of the union. =item B<< $constraint->check($value) >> =item B<< $constraint->validate($value) >> These two methods simply call the relevant method on each of the member type constraints in the union. If any type accepts the value, the value is valid. With C the error message returned includes all of the error messages returned by the member type constraints. =item B<< $constraint->equals($type_name_or_object) >> A type is considered equal if it is also a union type, and the two unions have the same member types. =item B<< $constraint->find_type_for($value) >> This returns the first member type constraint for which C is true, allowing you to determine which of the Union's member type constraints a given value matches. =item B<< $constraint->is_a_type_of($type_name_or_object) >> This returns true if all of the member type constraints return true for the C method. =item B<< $constraint->is_subtype_of >> This returns true if all of the member type constraints return true for the C method. =item B<< $constraint->create_child_type(%options) >> This returns a new L object with the type as its parent. =back =head1 BUGS See L for details on reporting bugs. =head1 AUTHOR Moose is maintained by the Moose Cabal, along with the help of many contributors. See L and L for details. =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2013 by Infinity Interactive, Inc.. This is free software; you can redistribute it and/or modify it under the same terms as the Perl 5 programming language system itself. =cut attribute_traits_n_meta.t100644000767000024 256212200352345 22074 0ustar00etherstaff000000000000Moose-2.1005/t/attributes#!/usr/bin/perl use strict; use warnings; use Test::More; use Test::Moose; { package My::Meta::Attribute::DefaultReadOnly; use Moose; extends 'Moose::Meta::Attribute'; around 'new' => sub { my $next = shift; my ($self, $name, %options) = @_; $options{is} = 'ro' unless exists $options{is}; $next->($self, $name, %options); }; } { package My::Attribute::Trait; use Moose::Role; has 'alias_to' => (is => 'ro', isa => 'Str'); after 'install_accessors' => sub { my $self = shift; $self->associated_class->add_method( $self->alias_to, $self->get_read_method_ref ); }; } { package My::Class; use Moose; has 'bar' => ( metaclass => 'My::Meta::Attribute::DefaultReadOnly', traits => [qw/My::Attribute::Trait/], isa => 'Int', alias_to => 'baz', ); } my $c = My::Class->new(bar => 100); isa_ok($c, 'My::Class'); is($c->bar, 100, '... got the right value for bar'); can_ok($c, 'baz'); is($c->baz, 100, '... got the right value for baz'); isa_ok($c->meta->get_attribute('bar'), 'My::Meta::Attribute::DefaultReadOnly'); does_ok($c->meta->get_attribute('bar'), 'My::Attribute::Trait'); is($c->meta->get_attribute('bar')->_is_metadata, 'ro', '... got the right metaclass customization'); done_testing; delegation_arg_aliasing.t100644000767000024 133412200352345 21767 0ustar00etherstaff000000000000Moose-2.1005/t/attributes#!/usr/bin/env perl use strict; use warnings; use Test::More; { package Foo; use Moose; sub aliased { my $self = shift; $_[1] = $_[0]; } } { package HasFoo; use Moose; has foo => ( is => 'ro', isa => 'Foo', handles => { foo_aliased => 'aliased', foo_aliased_curried => ['aliased', 'bar'], } ); } my $hasfoo = HasFoo->new(foo => Foo->new); my $x; $hasfoo->foo->aliased('foo', $x); is($x, 'foo', "direct aliasing works"); undef $x; $hasfoo->foo_aliased('foo', $x); is($x, 'foo', "delegated aliasing works"); undef $x; $hasfoo->foo_aliased_curried($x); is($x, 'bar', "delegated aliasing with currying works"); done_testing; method_generation_rules.t100644000767000024 341612200352345 22064 0ustar00etherstaff000000000000Moose-2.1005/t/attributes#!/usr/bin/perl use strict; use warnings; use Test::More; use Test::Fatal; =pod is => rw, writer => _foo # turns into (reader => foo, writer => _foo) is => ro, writer => _foo # turns into (reader => foo, writer => _foo) as before is => rw, accessor => _foo # turns into (accessor => _foo) is => ro, accessor => _foo # error, accesor is rw =cut sub make_class { my ($is, $attr, $class) = @_; eval "package $class; use Moose; has 'foo' => ( is => '$is', $attr => '_foo' );"; return $@ ? die $@ : $class; } my $obj; my $class; $class = make_class('rw', 'writer', 'Test::Class::WriterRW'); ok($class, "Can define attr with rw + writer"); $obj = $class->new(); can_ok($obj, qw/foo _foo/); is( exception {$obj->_foo(1)}, undef, "$class->_foo is writer" ); is($obj->foo(), 1, "$class->foo is reader"); isnt( exception {$obj->foo(2)}, undef, "$class->foo is not writer" ); # this should fail ok(!defined $obj->_foo(), "$class->_foo is not reader"); $class = make_class('ro', 'writer', 'Test::Class::WriterRO'); ok($class, "Can define attr with ro + writer"); $obj = $class->new(); can_ok($obj, qw/foo _foo/); is( exception {$obj->_foo(1)}, undef, "$class->_foo is writer" ); is($obj->foo(), 1, "$class->foo is reader"); isnt( exception {$obj->foo(1)}, undef, "$class->foo is not writer" ); isnt($obj->_foo(), 1, "$class->_foo is not reader"); $class = make_class('rw', 'accessor', 'Test::Class::AccessorRW'); ok($class, "Can define attr with rw + accessor"); $obj = $class->new(); can_ok($obj, qw/_foo/); is( exception {$obj->_foo(1)}, undef, "$class->_foo is writer" ); is($obj->_foo(), 1, "$class->foo is reader"); isnt( exception { make_class('ro', 'accessor', "Test::Class::AccessorRO"); }, undef, "Cant define attr with ro + accessor" ); done_testing; method_modifier_with_regexp.t100644000767000024 314612200352345 22000 0ustar00etherstaff000000000000Moose-2.1005/t/basics#!/usr/bin/perl use strict; use warnings; use Test::More; use Test::Fatal; { package Dog; use Moose; sub bark_once { my $self = shift; return 'bark'; } sub bark_twice { return 'barkbark'; } around qr/bark.*/ => sub { 'Dog::around(' . $_[0]->() . ')'; }; } my $dog = Dog->new; is( $dog->bark_once, 'Dog::around(bark)', 'around modifier is called' ); is( $dog->bark_twice, 'Dog::around(barkbark)', 'around modifier is called' ); { package Cat; use Moose; our $BEFORE_BARK_COUNTER = 0; our $AFTER_BARK_COUNTER = 0; sub bark_once { my $self = shift; return 'bark'; } sub bark_twice { return 'barkbark'; } before qr/bark.*/ => sub { $BEFORE_BARK_COUNTER++; }; after qr/bark.*/ => sub { $AFTER_BARK_COUNTER++; }; } my $cat = Cat->new; $cat->bark_once; is( $Cat::BEFORE_BARK_COUNTER, 1, 'before modifier is called once' ); is( $Cat::AFTER_BARK_COUNTER, 1, 'after modifier is called once' ); $cat->bark_twice; is( $Cat::BEFORE_BARK_COUNTER, 2, 'before modifier is called twice' ); is( $Cat::AFTER_BARK_COUNTER, 2, 'after modifier is called twice' ); { package Dog::Role; use Moose::Role; ::isnt( ::exception { before qr/bark.*/ => sub {}; }, undef, '... this is not currently supported' ); ::isnt( ::exception { around qr/bark.*/ => sub {}; }, undef, '... this is not currently supported' ); ::isnt( ::exception { after qr/bark.*/ => sub {}; }, undef, '... this is not currently supported' ); } done_testing; universal_methods_wrappable.t100644000767000024 66712200352345 22012 0ustar00etherstaff000000000000Moose-2.1005/t/basicsuse strict; use warnings; use Test::Fatal; use Test::More; { package FakeBar; use Moose::Role; around isa => sub { my ( $orig, $self, $v ) = @_; return 1 if $v eq 'Bar'; return $orig->( $self, $v ); }; package Foo; use Moose; use Test::More; ::is( ::exception { with 'FakeBar' }, undef, 'applied role' ); my $foo = Foo->new; ::isa_ok( $foo, 'Bar' ); } done_testing; immutable_metaclass_does_role.t100644000767000024 614112200352345 21775 0ustar00etherstaff000000000000Moose-2.1005/t/bugs#!/usr/bin/perl use strict; use warnings; use Test::More; use Test::Fatal; BEGIN { package MyRole; use Moose::Role; requires 'foo'; package MyMetaclass; use Moose qw(extends with); extends 'Moose::Meta::Class'; with 'MyRole'; sub foo { 'i am foo' } } { package MyClass; use metaclass ('MyMetaclass'); use Moose; } my $mc = MyMetaclass->initialize('MyClass'); isa_ok($mc, 'MyMetaclass'); ok($mc->meta->does_role('MyRole'), '... the metaclass does the role'); is(MyClass->meta, $mc, '... these metas are the same thing'); is(MyClass->meta->meta, $mc->meta, '... these meta-metas are the same thing'); my $a = MyClass->new; ok( $a->meta->meta->does_role('MyRole'), 'metaclass does MyRole' ); is( $a->meta->foo, 'i am foo', '... foo method returns expected value' ); ok( MyClass->meta->meta->does_role('MyRole'), 'metaclass does MyRole' ); is( MyClass->meta->foo, 'i am foo', '... foo method returns expected value' ); is( exception { MyClass->meta->make_immutable; }, undef, '... make MyClass immutable okay' ); is(MyClass->meta, $mc, '... these metas are still the same thing'); is(MyClass->meta->meta, $mc->meta, '... these meta-metas are the same thing'); ok( $a->meta->meta->does_role('MyRole'), 'metaclass does MyRole' ); is( $a->meta->foo, 'i am foo', '... foo method returns expected value' ); ok( MyClass->meta->meta->does_role('MyRole'), 'metaclass does MyRole' ); is( MyClass->meta->foo, 'i am foo', '... foo method returns expected value' ); is( exception { MyClass->meta->make_mutable; }, undef, '... make MyClass mutable okay' ); is(MyClass->meta, $mc, '... these metas are still the same thing'); is(MyClass->meta->meta, $mc->meta, '... these meta-metas are the same thing'); ok( $a->meta->meta->does_role('MyRole'), 'metaclass does MyRole' ); is( $a->meta->foo, 'i am foo', '... foo method returns expected value' ); ok( MyClass->meta->meta->does_role('MyRole'), 'metaclass does MyRole' ); is( MyClass->meta->foo, 'i am foo', '... foo method returns expected value' ); is( exception { MyMetaclass->meta->make_immutable; }, undef, '... make MyMetaclass immutable okay' ); is(MyClass->meta, $mc, '... these metas are still the same thing'); is(MyClass->meta->meta, $mc->meta, '... these meta-metas are the same thing'); ok( $a->meta->meta->does_role('MyRole'), 'metaclass does MyRole' ); is( $a->meta->foo, 'i am foo', '... foo method returns expected value' ); ok( MyClass->meta->meta->does_role('MyRole'), 'metaclass does MyRole' ); is( MyClass->meta->foo, 'i am foo', '... foo method returns expected value' ); is( exception { MyClass->meta->make_immutable; }, undef, '... make MyClass immutable (again) okay' ); is(MyClass->meta, $mc, '... these metas are still the same thing'); is(MyClass->meta->meta, $mc->meta, '... these meta-metas are the same thing'); ok( $a->meta->meta->does_role('MyRole'), 'metaclass does MyRole' ); is( $a->meta->foo, 'i am foo', '... foo method returns expected value' ); ok( MyClass->meta->meta->does_role('MyRole'), 'metaclass does MyRole' ); is( MyClass->meta->foo, 'i am foo', '... foo method returns expected value' ); done_testing; metaclass_incompatibility_dyn.t100644000767000024 245212200352345 22034 0ustar00etherstaff000000000000Moose-2.1005/t/cmopuse strict; use warnings; use Test::More; use metaclass; # meta classes { package Foo::Meta; use base 'Class::MOP::Class'; package Bar::Meta; use base 'Class::MOP::Class'; package FooBar::Meta; use base 'Foo::Meta', 'Bar::Meta'; } $@ = undef; eval { package Foo; metaclass->import('Foo::Meta'); }; ok(!$@, '... Foo.meta => Foo::Meta is compatible') || diag $@; $@ = undef; eval { package Bar; metaclass->import('Bar::Meta'); }; ok(!$@, '... Bar.meta => Bar::Meta is compatible') || diag $@; $@ = undef; eval { package Foo::Foo; metaclass->import('Bar::Meta'); Foo::Foo->meta->superclasses('Foo'); }; ok($@, '... Foo::Foo.meta => Bar::Meta is not compatible') || diag $@; $@ = undef; eval { package Bar::Bar; metaclass->import('Foo::Meta'); Bar::Bar->meta->superclasses('Bar'); }; ok($@, '... Bar::Bar.meta => Foo::Meta is not compatible') || diag $@; $@ = undef; eval { package FooBar; metaclass->import('FooBar::Meta'); FooBar->meta->superclasses('Foo'); }; ok(!$@, '... FooBar.meta => FooBar::Meta is compatible') || diag $@; $@ = undef; eval { package FooBar2; metaclass->import('FooBar::Meta'); FooBar2->meta->superclasses('Bar'); }; ok(!$@, '... FooBar2.meta => FooBar::Meta is compatible') || diag $@; done_testing; scala_style_mixin_composition.t100644000767000024 1062612200352345 22102 0ustar00etherstaff000000000000Moose-2.1005/t/cmopuse strict; use warnings; use Test::More; use Test::Requires { 'SUPER' => 1.10, # skip all if not installed }; =pod This test demonstrates how simple it is to create Scala Style Class Mixin Composition. Below is an example taken from the Scala web site's example section, and trancoded to Class::MOP. NOTE: We require SUPER for this test to handle the issue with SUPER:: being determined at compile time. L A class can only be used as a mixin in the definition of another class, if this other class extends a subclass of the superclass of the mixin. Since ColoredPoint3D extends Point3D and Point3D extends Point2D which is the superclass of ColoredPoint2D, the code above is well-formed. class Point2D(xc: Int, yc: Int) { val x = xc; val y = yc; override def toString() = "x = " + x + ", y = " + y; } class ColoredPoint2D(u: Int, v: Int, c: String) extends Point2D(u, v) { val color = c; def setColor(newCol: String): Unit = color = newCol; override def toString() = super.toString() + ", col = " + color; } class Point3D(xc: Int, yc: Int, zc: Int) extends Point2D(xc, yc) { val z = zc; override def toString() = super.toString() + ", z = " + z; } class ColoredPoint3D(xc: Int, yc: Int, zc: Int, col: String) extends Point3D(xc, yc, zc) with ColoredPoint2D(xc, yc, col); Console.println(new ColoredPoint3D(1, 2, 3, "blue").toString()) "x = 1, y = 2, z = 3, col = blue" =cut use Scalar::Util 'blessed'; use Carp 'confess'; sub ::with ($) { # fetch the metaclass for the # caller and the mixin arg my $metaclass = (caller)->meta; my $mixin = (shift)->meta; # according to Scala, the # the superclass of our class # must be a subclass of the # superclass of the mixin (see above) my ($super_meta) = $metaclass->superclasses(); my ($super_mixin) = $mixin->superclasses(); ($super_meta->isa($super_mixin)) || confess "The superclass must extend a subclass of the superclass of the mixin"; # collect all the attributes # and clone them so they can # associate with the new class my @attributes = map { $mixin->get_attribute($_)->clone() } $mixin->get_attribute_list; my %methods = map { my $method = $mixin->get_method($_); # we want to ignore accessors since # they will be created with the attrs (blessed($method) && $method->isa('Class::MOP::Method::Accessor')) ? () : ($_ => $method) } $mixin->get_method_list; # NOTE: # I assume that locally defined methods # and attributes get precedence over those # from the mixin. # add all the attributes in .... foreach my $attr (@attributes) { $metaclass->add_attribute($attr) unless $metaclass->has_attribute($attr->name); } # add all the methods in .... foreach my $method_name (keys %methods) { $metaclass->add_method($method_name => $methods{$method_name}) unless $metaclass->has_method($method_name); } } { package Point2D; use metaclass; Point2D->meta->add_attribute('$x' => ( accessor => 'x', init_arg => 'x', )); Point2D->meta->add_attribute('$y' => ( accessor => 'y', init_arg => 'y', )); sub new { my $class = shift; $class->meta->new_object(@_); } sub toString { my $self = shift; "x = " . $self->x . ", y = " . $self->y; } package ColoredPoint2D; our @ISA = ('Point2D'); ColoredPoint2D->meta->add_attribute('$color' => ( accessor => 'color', init_arg => 'color', )); sub toString { my $self = shift; $self->SUPER() . ', col = ' . $self->color; } package Point3D; our @ISA = ('Point2D'); Point3D->meta->add_attribute('$z' => ( accessor => 'z', init_arg => 'z', )); sub toString { my $self = shift; $self->SUPER() . ', z = ' . $self->z; } package ColoredPoint3D; our @ISA = ('Point3D'); ::with('ColoredPoint2D'); } my $colored_point_3d = ColoredPoint3D->new(x => 1, y => 2, z => 3, color => 'blue'); isa_ok($colored_point_3d, 'ColoredPoint3D'); isa_ok($colored_point_3d, 'Point3D'); isa_ok($colored_point_3d, 'Point2D'); is($colored_point_3d->toString(), 'x = 1, y = 2, z = 3, col = blue', '... got the right toString method'); done_testing; Child_Parent_attr_inherit.t100644000767000024 651412200352345 21721 0ustar00etherstaff000000000000Moose-2.1005/t/examples#!/usr/bin/perl use strict; use warnings; use Test::More; =pod Some examples of triggers and how they can be used to manage parent-child relationships. =cut { package Parent; use Moose; has 'last_name' => ( is => 'rw', isa => 'Str', trigger => sub { my $self = shift; # if the parents last-name changes # then so do all the childrens foreach my $child ( @{ $self->children } ) { $child->last_name( $self->last_name ); } } ); has 'children' => ( is => 'rw', isa => 'ArrayRef', default => sub { [] } ); } { package Child; use Moose; has 'parent' => ( is => 'rw', isa => 'Parent', required => 1, trigger => sub { my $self = shift; # if the parent is changed,.. # make sure we update $self->last_name( $self->parent->last_name ); } ); has 'last_name' => ( is => 'rw', isa => 'Str', lazy => 1, default => sub { (shift)->parent->last_name } ); } my $parent = Parent->new( last_name => 'Smith' ); isa_ok( $parent, 'Parent' ); is( $parent->last_name, 'Smith', '... the parent has the last name we expected' ); $parent->children( [ map { Child->new( parent => $parent ) } ( 0 .. 3 ) ] ); foreach my $child ( @{ $parent->children } ) { is( $child->last_name, $parent->last_name, '... parent and child have the same last name (' . $parent->last_name . ')' ); } $parent->last_name('Jones'); is( $parent->last_name, 'Jones', '... the parent has the new last name' ); foreach my $child ( @{ $parent->children } ) { is( $child->last_name, $parent->last_name, '... parent and child have the same last name (' . $parent->last_name . ')' ); } # make a new parent my $parent2 = Parent->new( last_name => 'Brown' ); isa_ok( $parent2, 'Parent' ); # orphan the child my $orphan = pop @{ $parent->children }; # and then the new parent adopts it $orphan->parent($parent2); foreach my $child ( @{ $parent->children } ) { is( $child->last_name, $parent->last_name, '... parent and child have the same last name (' . $parent->last_name . ')' ); } isnt( $orphan->last_name, $parent->last_name, '... the orphan child does not have the same last name anymore (' . $parent2->last_name . ')' ); is( $orphan->last_name, $parent2->last_name, '... parent2 and orphan child have the same last name (' . $parent2->last_name . ')' ); # make sure that changes still will not propagate $parent->last_name('Miller'); is( $parent->last_name, 'Miller', '... the parent has the new last name (again)' ); foreach my $child ( @{ $parent->children } ) { is( $child->last_name, $parent->last_name, '... parent and child have the same last name (' . $parent->last_name . ')' ); } isnt( $orphan->last_name, $parent->last_name, '... the orphan child is not affected by changes in the parent anymore' ); is( $orphan->last_name, $parent2->last_name, '... parent2 and orphan child have the same last name (' . $parent2->last_name . ')' ); done_testing; apply_roles_to_immutable.t100644000767000024 121312200352345 22033 0ustar00etherstaff000000000000Moose-2.1005/t/immutable#!/usr/bin/perl use strict; use warnings; use Test::More; use Test::Fatal; { package My::Role; use Moose::Role; around 'baz' => sub { my $next = shift; 'My::Role::baz(' . $next->(@_) . ')'; }; } { package Foo; use Moose; sub baz { 'Foo::baz' } __PACKAGE__->meta->make_immutable(debug => 0); } my $foo = Foo->new; isa_ok($foo, 'Foo'); is($foo->baz, 'Foo::baz', '... got the right value'); is( exception { My::Role->meta->apply($foo) }, undef, '... successfully applied the role to immutable instance' ); is($foo->baz, 'My::Role::baz(Foo::baz)', '... got the right value'); done_testing; constructor_is_not_moose.t100644000767000024 365012200352345 22112 0ustar00etherstaff000000000000Moose-2.1005/t/immutable#!/usr/bin/perl use strict; use warnings; use Test::More; use Test::Requires { 'Test::Output' => '0.01', # skip all if not installed }; { package NotMoose; sub new { my $class = shift; return bless { not_moose => 1 }, $class; } } { package Foo; use Moose; extends 'NotMoose'; ::stderr_like( sub { Foo->meta->make_immutable }, qr/\QNot inlining 'new' for Foo since it is not inheriting the default Moose::Object::new\E\s+\QIf you are certain you don't need to inline your constructor, specify inline_constructor => 0 in your call to Foo->meta->make_immutable/, 'got a warning that Foo may not have an inlined constructor' ); } is( Foo->meta->find_method_by_name('new')->body, NotMoose->can('new'), 'Foo->new is inherited from NotMoose' ); { package Bar; use Moose; extends 'NotMoose'; ::stderr_is( sub { Bar->meta->make_immutable( replace_constructor => 1 ) }, q{}, 'no warning when replace_constructor is true' ); } is( Bar->meta->find_method_by_name('new')->package_name, 'Bar', 'Bar->new is inlined, and not inherited from NotMoose' ); { package Baz; use Moose; Baz->meta->make_immutable; } { package Quux; use Moose; extends 'Baz'; ::stderr_is( sub { Quux->meta->make_immutable }, q{}, 'no warning when inheriting from a class that has already made itself immutable' ); } { package My::Constructor; use base 'Moose::Meta::Method::Constructor'; } { package CustomCons; use Moose; CustomCons->meta->make_immutable( constructor_class => 'My::Constructor' ); } { package Subclass; use Moose; extends 'CustomCons'; ::stderr_is( sub { Subclass->meta->make_immutable }, q{}, 'no warning when inheriting from a class that has already made itself immutable' ); } done_testing; multiple_demolish_inline.t100644000767000024 145712200352345 22030 0ustar00etherstaff000000000000Moose-2.1005/t/immutable#!/usr/bin/perl use strict; use warnings; use Test::More; use Test::Fatal; { package Foo; use Moose; has 'foo' => (is => 'rw', isa => 'Int'); sub DEMOLISH { } } { package Bar; use Moose; extends qw(Foo); has 'bar' => (is => 'rw', isa => 'Int'); sub DEMOLISH { } } is( exception { Bar->new(); }, undef, 'Bar->new()' ); is( exception { Bar->meta->make_immutable; }, undef, 'Bar->meta->make_immutable' ); is( Bar->meta->get_method('DESTROY')->package_name, 'Bar', 'Bar has a DESTROY method in the Bar class (not inherited)' ); is( exception { Foo->meta->make_immutable; }, undef, 'Foo->meta->make_immutable' ); is( Foo->meta->get_method('DESTROY')->package_name, 'Foo', 'Foo has a DESTROY method in the Bar class (not inherited)' ); done_testing; metaroles_of_metaroles.t100755000767000024 262112200352345 22027 0ustar00etherstaff000000000000Moose-2.1005/t/metaclasses#!/usr/bin/env perl use strict; use warnings; use Test::More; use Test::Fatal; { package ApplicationMetaRole; use Moose::Role; use Moose::Util::MetaRole; after apply => sub { my ($self, $role_source, $role_dest, $args) = @_; Moose::Util::MetaRole::apply_metaroles ( for => $role_dest, role_metaroles => { application_to_role => ['ApplicationMetaRole'], } ); }; } { package MyMetaRole; use Moose::Role; use Moose::Util::MetaRole; use Moose::Exporter; Moose::Exporter->setup_import_methods(also => q); sub init_meta { my ($class, %opts) = @_; Moose::Role->init_meta(%opts); Moose::Util::MetaRole::apply_metaroles ( for => $opts{for_class}, role_metaroles => { application_to_role => ['ApplicationMetaRole'], } ); return $opts{for_class}->meta(); }; } { package MyRole; use Moose::Role; MyMetaRole->import; use Moose::Util::TypeConstraints; has schema => ( is => 'ro', coerce => 1, ); } { package MyTargetRole; use Moose::Role; ::is(::exception { with "MyRole" }, undef, "apply a meta role to a role, which is then applied to yet another role"); } done_testing; role_composition_method_mods.t100644000767000024 352012200352345 22057 0ustar00etherstaff000000000000Moose-2.1005/t/roles#!/usr/bin/perl use strict; use warnings; use Test::More; use Test::Fatal; use Moose::Meta::Role::Application::RoleSummation; use Moose::Meta::Role::Composite; { package Role::Foo; use Moose::Role; before foo => sub { 'Role::Foo::foo' }; around foo => sub { 'Role::Foo::foo' }; after foo => sub { 'Role::Foo::foo' }; around baz => sub { [ 'Role::Foo', @{shift->(@_)} ] }; package Role::Bar; use Moose::Role; before bar => sub { 'Role::Bar::bar' }; around bar => sub { 'Role::Bar::bar' }; after bar => sub { 'Role::Bar::bar' }; package Role::Baz; use Moose::Role; with 'Role::Foo'; around baz => sub { [ 'Role::Baz', @{shift->(@_)} ] }; } { package Class::FooBar; use Moose; with 'Role::Baz'; sub foo { 'placeholder' } sub baz { ['Class::FooBar'] } } #test modifier call order { is_deeply( Class::FooBar->baz, ['Role::Baz','Role::Foo','Class::FooBar'] ); } # test simple overrides { my $c = Moose::Meta::Role::Composite->new( roles => [ Role::Foo->meta, Role::Bar->meta, ] ); isa_ok($c, 'Moose::Meta::Role::Composite'); is($c->name, 'Role::Foo|Role::Bar', '... got the composite role name'); is( exception { Moose::Meta::Role::Application::RoleSummation->new->apply($c); }, undef, '... this succeeds as expected' ); is_deeply( [ sort $c->get_method_modifier_list('before') ], [ 'bar', 'foo' ], '... got the right list of methods' ); is_deeply( [ sort $c->get_method_modifier_list('after') ], [ 'bar', 'foo' ], '... got the right list of methods' ); is_deeply( [ sort $c->get_method_modifier_list('around') ], [ 'bar', 'baz', 'foo' ], '... got the right list of methods' ); } done_testing; role_composition_req_methods.t100644000767000024 567412200352345 22103 0ustar00etherstaff000000000000Moose-2.1005/t/roles#!/usr/bin/perl use strict; use warnings; use Test::More; use Test::Fatal; use Moose::Meta::Role::Application::RoleSummation; use Moose::Meta::Role::Composite; { package Role::Foo; use Moose::Role; requires 'foo'; package Role::Bar; use Moose::Role; requires 'bar'; package Role::ProvidesFoo; use Moose::Role; sub foo { 'Role::ProvidesFoo::foo' } package Role::ProvidesBar; use Moose::Role; sub bar { 'Role::ProvidesBar::bar' } } # test simple requirement { my $c = Moose::Meta::Role::Composite->new( roles => [ Role::Foo->meta, Role::Bar->meta, ] ); isa_ok($c, 'Moose::Meta::Role::Composite'); is($c->name, 'Role::Foo|Role::Bar', '... got the composite role name'); is( exception { Moose::Meta::Role::Application::RoleSummation->new->apply($c); }, undef, '... this succeeds as expected' ); is_deeply( [ sort $c->get_required_method_list ], [ 'bar', 'foo' ], '... got the right list of required methods' ); } # test requirement satisfied { my $c = Moose::Meta::Role::Composite->new( roles => [ Role::Foo->meta, Role::ProvidesFoo->meta, ] ); isa_ok($c, 'Moose::Meta::Role::Composite'); is($c->name, 'Role::Foo|Role::ProvidesFoo', '... got the composite role name'); is( exception { Moose::Meta::Role::Application::RoleSummation->new->apply($c); }, undef, '... this succeeds as expected' ); is_deeply( [ sort $c->get_required_method_list ], [], '... got the right list of required methods' ); } # test requirement satisfied { my $c = Moose::Meta::Role::Composite->new( roles => [ Role::Foo->meta, Role::ProvidesFoo->meta, Role::Bar->meta, ] ); isa_ok($c, 'Moose::Meta::Role::Composite'); is($c->name, 'Role::Foo|Role::ProvidesFoo|Role::Bar', '... got the composite role name'); is( exception { Moose::Meta::Role::Application::RoleSummation->new->apply($c); }, undef, '... this succeeds as expected' ); is_deeply( [ sort $c->get_required_method_list ], [ 'bar' ], '... got the right list of required methods' ); } # test requirement satisfied { my $c = Moose::Meta::Role::Composite->new( roles => [ Role::Foo->meta, Role::ProvidesFoo->meta, Role::ProvidesBar->meta, Role::Bar->meta, ] ); isa_ok($c, 'Moose::Meta::Role::Composite'); is($c->name, 'Role::Foo|Role::ProvidesFoo|Role::ProvidesBar|Role::Bar', '... got the composite role name'); is( exception { Moose::Meta::Role::Application::RoleSummation->new->apply($c); }, undef, '... this succeeds as expected' ); is_deeply( [ sort $c->get_required_method_list ], [ ], '... got the right list of required methods' ); } done_testing; role_exclusion_and_alias_bug.t100644000767000024 236212200352345 21776 0ustar00etherstaff000000000000Moose-2.1005/t/roles#!/usr/bin/perl use strict; use warnings; use Test::More; use Test::Moose; { package My::Role; use Moose::Role; sub foo { "FOO" } sub bar { "BAR" } } { package My::Class; use Moose; with 'My::Role' => { -alias => { foo => 'baz', bar => 'gorch' }, -excludes => ['foo', 'bar'], }; } { my $x = My::Class->new; isa_ok($x, 'My::Class'); does_ok($x, 'My::Role'); can_ok($x, $_) for qw[baz gorch]; ok(!$x->can($_), '... cant call method ' . $_) for qw[foo bar]; is($x->baz, 'FOO', '... got the right value'); is($x->gorch, 'BAR', '... got the right value'); } { package My::Role::Again; use Moose::Role; with 'My::Role' => { -alias => { foo => 'baz', bar => 'gorch' }, -excludes => ['foo', 'bar'], }; package My::Class::Again; use Moose; with 'My::Role::Again'; } { my $x = My::Class::Again->new; isa_ok($x, 'My::Class::Again'); does_ok($x, 'My::Role::Again'); does_ok($x, 'My::Role'); can_ok($x, $_) for qw[baz gorch]; ok(!$x->can($_), '... cant call method ' . $_) for qw[foo bar]; is($x->baz, 'FOO', '... got the right value'); is($x->gorch, 'BAR', '... got the right value'); } done_testing; replacing_super_methods.t100644000767000024 144712200352345 22067 0ustar00etherstaff000000000000Moose-2.1005/t/todo_tests#!/usr/bin/env perl use strict; use warnings; use Test::More; my ($super_called, $sub_called, $new_super_called) = (0, 0, 0); { package Foo; use Moose; sub foo { $super_called++ } } { package Foo::Sub; use Moose; extends 'Foo'; override foo => sub { $sub_called++; super(); }; } Foo::Sub->new->foo; is($super_called, 1, "super called"); is($new_super_called, 0, "new super not called"); is($sub_called, 1, "sub called"); ($super_called, $sub_called, $new_super_called) = (0, 0, 0); Foo->meta->add_method(foo => sub { $new_super_called++; }); Foo::Sub->new->foo; { local $TODO = "super doesn't get replaced"; is($super_called, 0, "super not called"); is($new_super_called, 1, "new super called"); } is($sub_called, 1, "sub called"); done_testing; required_role_accessors.t100644000767000024 156712200352345 22073 0ustar00etherstaff000000000000Moose-2.1005/t/todo_tests#!/usr/bin/env perl use strict; use warnings; use Test::More; use Test::Fatal; { package Foo::API; use Moose::Role; requires 'foo'; } { package Foo; use Moose::Role; has foo => (is => 'ro'); with 'Foo::API'; } { package Foo::Class; use Moose; { our $TODO; local $TODO = "role accessors don't satisfy other role requires"; ::is( ::exception { with 'Foo' }, undef, 'requirements are satisfied properly' ); } } { package Bar; use Moose::Role; requires 'baz'; has bar => (is => 'ro'); } { package Baz; use Moose::Role; requires 'bar'; has baz => (is => 'ro'); } { package BarBaz; use Moose; { our $TODO; local $TODO = "role accessors don't satisfy other role requires"; ::is( ::exception { with qw(Bar Baz) }, undef, 'requirements are satisfied properly' ); } } done_testing; duck_type_handles.t100644000767000024 132412200352345 22062 0ustar00etherstaff000000000000Moose-2.1005/t/type_constraints#!/usr/bin/perl use strict; use warnings; use Test::More; my @phonograph; { package Duck; use Moose; sub walk { push @phonograph, 'footsteps', } sub quack { push @phonograph, 'quack'; } package Swan; use Moose; sub honk { push @phonograph, 'honk'; } package DucktypeTest; use Moose; use Moose::Util::TypeConstraints; my $ducktype = duck_type 'DuckType' => qw(walk quack); has duck => ( isa => $ducktype, handles => $ducktype, ); } my $t = DucktypeTest->new(duck => Duck->new); $t->quack; is_deeply([splice @phonograph], ['quack']); $t->walk; is_deeply([splice @phonograph], ['footsteps']); done_testing; parameterize_from.t100644000767000024 434212200352345 22113 0ustar00etherstaff000000000000Moose-2.1005/t/type_constraints#!/usr/bin/perl use strict; use warnings; use Test::More; use Test::Fatal; use Moose::Util::TypeConstraints; # testing the parameterize method { my $parameterizable = subtype 'parameterizable_hashref', as 'HashRef'; my $parameterized = subtype 'parameterized_hashref', as 'HashRef[Int]'; my $int = Moose::Util::TypeConstraints::find_type_constraint('Int'); my $from_parameterizable = $parameterizable->parameterize($int); isa_ok $parameterizable, 'Moose::Meta::TypeConstraint::Parameterizable', => 'Got expected type instance'; package Test::Moose::Meta::TypeConstraint::Parameterizable; use Moose; has parameterizable => ( is => 'rw', isa => $parameterizable ); has parameterized => ( is => 'rw', isa => $parameterized ); has from_parameterizable => ( is => 'rw', isa => $from_parameterizable ); } # Create and check a dummy object ok my $params = Test::Moose::Meta::TypeConstraint::Parameterizable->new() => 'Create Dummy object for testing'; isa_ok $params, 'Test::Moose::Meta::TypeConstraint::Parameterizable' => 'isa correct type'; # test parameterizable is( exception { $params->parameterizable( { a => 'Hello', b => 'World' } ); }, undef, 'No problem setting parameterizable' ); is_deeply $params->parameterizable, { a => 'Hello', b => 'World' } => 'Got expected values'; # test parameterized is( exception { $params->parameterized( { a => 1, b => 2 } ); }, undef, 'No problem setting parameterized' ); is_deeply $params->parameterized, { a => 1, b => 2 } => 'Got expected values'; like( exception { $params->parameterized( { a => 'Hello', b => 'World' } ); }, qr/Attribute \(parameterized\) does not pass the type constraint/, 'parameterized throws expected error' ); # test from_parameterizable is( exception { $params->from_parameterizable( { a => 1, b => 2 } ); }, undef, 'No problem setting from_parameterizable' ); is_deeply $params->from_parameterizable, { a => 1, b => 2 } => 'Got expected values'; like( exception { $params->from_parameterizable( { a => 'Hello', b => 'World' } ); }, qr/Attribute \(from_parameterizable\) does not pass the type constraint/, 'from_parameterizable throws expected error' ); done_testing; roles_comparable_codereuse.t100644000767000024 1225012200352345 22006 0ustar00etherstaff000000000000Moose-2.1005/t/recipes#!/usr/bin/perl -w use strict; use Test::More 'no_plan'; use Test::Fatal; $| = 1; # =begin testing SETUP { package Eq; use Moose::Role; requires 'equal_to'; sub not_equal_to { my ( $self, $other ) = @_; not $self->equal_to($other); } package Comparable; use Moose::Role; with 'Eq'; requires 'compare'; sub equal_to { my ( $self, $other ) = @_; $self->compare($other) == 0; } sub greater_than { my ( $self, $other ) = @_; $self->compare($other) == 1; } sub less_than { my ( $self, $other ) = @_; $self->compare($other) == -1; } sub greater_than_or_equal_to { my ( $self, $other ) = @_; $self->greater_than($other) || $self->equal_to($other); } sub less_than_or_equal_to { my ( $self, $other ) = @_; $self->less_than($other) || $self->equal_to($other); } package Printable; use Moose::Role; requires 'to_string'; package US::Currency; use Moose; with 'Comparable', 'Printable'; has 'amount' => ( is => 'rw', isa => 'Num', default => 0 ); sub compare { my ( $self, $other ) = @_; $self->amount <=> $other->amount; } sub to_string { my $self = shift; sprintf '$%0.2f USD' => $self->amount; } } # =begin testing { ok( US::Currency->does('Comparable'), '... US::Currency does Comparable' ); ok( US::Currency->does('Eq'), '... US::Currency does Eq' ); ok( US::Currency->does('Printable'), '... US::Currency does Printable' ); my $hundred = US::Currency->new( amount => 100.00 ); isa_ok( $hundred, 'US::Currency' ); ok( $hundred->DOES("US::Currency"), "UNIVERSAL::DOES for class" ); ok( $hundred->DOES("Comparable"), "UNIVERSAL::DOES for role" ); can_ok( $hundred, 'amount' ); is( $hundred->amount, 100, '... got the right amount' ); can_ok( $hundred, 'to_string' ); is( $hundred->to_string, '$100.00 USD', '... got the right stringified value' ); ok( $hundred->does('Comparable'), '... US::Currency does Comparable' ); ok( $hundred->does('Eq'), '... US::Currency does Eq' ); ok( $hundred->does('Printable'), '... US::Currency does Printable' ); my $fifty = US::Currency->new( amount => 50.00 ); isa_ok( $fifty, 'US::Currency' ); can_ok( $fifty, 'amount' ); is( $fifty->amount, 50, '... got the right amount' ); can_ok( $fifty, 'to_string' ); is( $fifty->to_string, '$50.00 USD', '... got the right stringified value' ); ok( $hundred->greater_than($fifty), '... 100 gt 50' ); ok( $hundred->greater_than_or_equal_to($fifty), '... 100 ge 50' ); ok( !$hundred->less_than($fifty), '... !100 lt 50' ); ok( !$hundred->less_than_or_equal_to($fifty), '... !100 le 50' ); ok( !$hundred->equal_to($fifty), '... !100 eq 50' ); ok( $hundred->not_equal_to($fifty), '... 100 ne 50' ); ok( !$fifty->greater_than($hundred), '... !50 gt 100' ); ok( !$fifty->greater_than_or_equal_to($hundred), '... !50 ge 100' ); ok( $fifty->less_than($hundred), '... 50 lt 100' ); ok( $fifty->less_than_or_equal_to($hundred), '... 50 le 100' ); ok( !$fifty->equal_to($hundred), '... !50 eq 100' ); ok( $fifty->not_equal_to($hundred), '... 50 ne 100' ); ok( !$fifty->greater_than($fifty), '... !50 gt 50' ); ok( $fifty->greater_than_or_equal_to($fifty), '... !50 ge 50' ); ok( !$fifty->less_than($fifty), '... 50 lt 50' ); ok( $fifty->less_than_or_equal_to($fifty), '... 50 le 50' ); ok( $fifty->equal_to($fifty), '... 50 eq 50' ); ok( !$fifty->not_equal_to($fifty), '... !50 ne 50' ); ## ... check some meta-stuff # Eq my $eq_meta = Eq->meta; isa_ok( $eq_meta, 'Moose::Meta::Role' ); ok( $eq_meta->has_method('not_equal_to'), '... Eq has_method not_equal_to' ); ok( $eq_meta->requires_method('equal_to'), '... Eq requires_method not_equal_to' ); # Comparable my $comparable_meta = Comparable->meta; isa_ok( $comparable_meta, 'Moose::Meta::Role' ); ok( $comparable_meta->does_role('Eq'), '... Comparable does Eq' ); foreach my $method_name ( qw( equal_to not_equal_to greater_than greater_than_or_equal_to less_than less_than_or_equal_to ) ) { ok( $comparable_meta->has_method($method_name), '... Comparable has_method ' . $method_name ); } ok( $comparable_meta->requires_method('compare'), '... Comparable requires_method compare' ); # Printable my $printable_meta = Printable->meta; isa_ok( $printable_meta, 'Moose::Meta::Role' ); ok( $printable_meta->requires_method('to_string'), '... Printable requires_method to_string' ); # US::Currency my $currency_meta = US::Currency->meta; isa_ok( $currency_meta, 'Moose::Meta::Class' ); ok( $currency_meta->does_role('Comparable'), '... US::Currency does Comparable' ); ok( $currency_meta->does_role('Eq'), '... US::Currency does Eq' ); ok( $currency_meta->does_role('Printable'), '... US::Currency does Printable' ); foreach my $method_name ( qw( amount equal_to not_equal_to compare greater_than greater_than_or_equal_to less_than less_than_or_equal_to to_string ) ) { ok( $currency_meta->has_method($method_name), '... US::Currency has_method ' . $method_name ); } } 1; Basics000755000767000024 012200352345 16777 5ustar00etherstaff000000000000Moose-2.1005/lib/Moose/CookbookImmutable.pod100644000767000024 273612200352345 21572 0ustar00etherstaff000000000000Moose-2.1005/lib/Moose/Cookbook/Basicspackage Moose::Cookbook::Basics::Immutable; # ABSTRACT: Making Moose fast by making your class immutable __END__ =pod =head1 NAME Moose::Cookbook::Basics::Immutable - Making Moose fast by making your class immutable =head1 VERSION version 2.1005 =head1 SYNOPSIS package Point; use Moose; has 'x' => ( isa => 'Int', is => 'ro' ); has 'y' => ( isa => 'Int', is => 'rw' ); __PACKAGE__->meta->make_immutable; =head1 DESCRIPTION The Moose metaclass API provides a C method. Calling this method does two things to your class. First, it makes it faster. In particular, object construction and destruction are effectively "inlined" in your class, and no longer invoke the meta API. Second, you can no longer make changes via the metaclass API, such as adding attributes. In practice, this won't be a problem, as you rarely need to do this after first loading the class. =head1 CONCLUSION We strongly recommend you make your classes immutable. It makes your code much faster, with a small compile-time cost. This will be especially noticeable when creating many objects. =head1 AUTHOR Moose is maintained by the Moose Cabal, along with the help of many contributors. See L and L for details. =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2013 by Infinity Interactive, Inc.. This is free software; you can redistribute it and/or modify it under the same terms as the Perl 5 programming language system itself. =cut Immutable000755000767000024 012200352345 17677 5ustar00etherstaff000000000000Moose-2.1005/lib/Moose/Meta/ClassTrait.pm100644000767000024 347012200352345 21464 0ustar00etherstaff000000000000Moose-2.1005/lib/Moose/Meta/Class/Immutablepackage Moose::Meta::Class::Immutable::Trait; BEGIN { $Moose::Meta::Class::Immutable::Trait::AUTHORITY = 'cpan:STEVAN'; } { $Moose::Meta::Class::Immutable::Trait::VERSION = '2.1005'; } use strict; use warnings; use Class::MOP; use Scalar::Util qw( blessed ); use base 'Class::MOP::Class::Immutable::Trait'; sub add_role { $_[1]->_immutable_cannot_call } sub calculate_all_roles { my $orig = shift; my $self = shift; @{ $self->{__immutable}{calculate_all_roles} ||= [ $self->$orig ] }; } sub calculate_all_roles_with_inheritance { my $orig = shift; my $self = shift; @{ $self->{__immutable}{calculate_all_roles_with_inheritance} ||= [ $self->$orig ] }; } sub does_role { shift; my $self = shift; my $role = shift; (defined $role) || $self->throw_error("You must supply a role name to look for"); $self->{__immutable}{does_role} ||= { map { $_->name => 1 } $self->calculate_all_roles_with_inheritance }; my $name = blessed $role ? $role->name : $role; return $self->{__immutable}{does_role}{$name}; } 1; # ABSTRACT: Implements immutability for metaclass objects __END__ =pod =head1 NAME Moose::Meta::Class::Immutable::Trait - Implements immutability for metaclass objects =head1 VERSION version 2.1005 =head1 DESCRIPTION This class makes some Moose-specific metaclass methods immutable. This is deep guts. =head1 BUGS See L for details on reporting bugs. =head1 AUTHOR Moose is maintained by the Moose Cabal, along with the help of many contributors. See L and L for details. =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2013 by Infinity Interactive, Inc.. This is free software; you can redistribute it and/or modify it under the same terms as the Perl 5 programming language system itself. =cut accessor_override_method.t100644000767000024 332712200352345 22221 0ustar00etherstaff000000000000Moose-2.1005/t/attributes#!/usr/bin/env perl use strict; use warnings; use Test::More; use Test::Requires { 'Test::Output' => '0.01', # skip all if not installed }; { package Foo; use Moose; sub get_a { } sub set_b { } sub has_c { } sub clear_d { } sub e { } sub stub; } my $foo_meta = Foo->meta; stderr_like( sub { $foo_meta->add_attribute( a => ( reader => 'get_a' ) ) }, qr/^You are overwriting a locally defined method \(get_a\) with an accessor/, 'reader overriding gives proper warning' ); stderr_like( sub { $foo_meta->add_attribute( b => ( writer => 'set_b' ) ) }, qr/^You are overwriting a locally defined method \(set_b\) with an accessor/, 'writer overriding gives proper warning' ); stderr_like( sub { $foo_meta->add_attribute( c => ( predicate => 'has_c' ) ) }, qr/^You are overwriting a locally defined method \(has_c\) with an accessor/, 'predicate overriding gives proper warning' ); stderr_like( sub { $foo_meta->add_attribute( d => ( clearer => 'clear_d' ) ) }, qr/^You are overwriting a locally defined method \(clear_d\) with an accessor/, 'clearer overriding gives proper warning' ); stderr_like( sub { $foo_meta->add_attribute( e => ( is => 'rw' ) ) }, qr/^You are overwriting a locally defined method \(e\) with an accessor/, 'accessor overriding gives proper warning' ); stderr_is( sub { $foo_meta->add_attribute( stub => ( is => 'rw' ) ) }, q{}, 'overriding a stub with an accessor does not warn' ); stderr_like( sub { $foo_meta->add_attribute( has => ( is => 'rw' ) ) }, qr/^You are overwriting a locally defined function \(has\) with an accessor/, 'function overriding gives proper warning' ); done_testing; default_class_role_types.t100644000767000024 244012200352345 22231 0ustar00etherstaff000000000000Moose-2.1005/t/attributes#!/usr/bin/env perl use strict; use warnings; use Test::More; use Test::Fatal; use Moose::Util::TypeConstraints; { package Foo; use Moose; has unknown_class => ( is => 'ro', isa => 'UnknownClass', ); has unknown_role => ( is => 'ro', does => 'UnknownRole', ); } { my $meta = Foo->meta; my $class_tc = $meta->get_attribute('unknown_class')->type_constraint; isa_ok($class_tc, 'Moose::Meta::TypeConstraint::Class'); is($class_tc, find_type_constraint('UnknownClass'), "class type is registered"); like( exception { subtype 'UnknownClass', as 'Str'; }, qr/The type constraint 'UnknownClass' has already been created in Foo and cannot be created again in main/, "Can't redefine implicitly defined class types" ); my $role_tc = $meta->get_attribute('unknown_role')->type_constraint; isa_ok($role_tc, 'Moose::Meta::TypeConstraint::Role'); is($role_tc, find_type_constraint('UnknownRole'), "role type is registered"); like( exception { subtype 'UnknownRole', as 'Str'; }, qr/The type constraint 'UnknownRole' has already been created in Foo and cannot be created again in main/, "Can't redefine implicitly defined class types" ); } done_testing; delegation_and_modifiers.t100644000767000024 167612200352345 22163 0ustar00etherstaff000000000000Moose-2.1005/t/attributes#!/usr/bin/perl use strict; use warnings; use Test::More; { package Bar; use Moose; sub baz { 'Bar::baz' } sub gorch { 'Bar::gorch' } package Foo; use Moose; has 'bar' => ( is => 'ro', isa => 'Bar', lazy => 1, default => sub { Bar->new }, handles => [qw[ baz gorch ]] ); package Foo::Extended; use Moose; extends 'Foo'; has 'test' => ( is => 'rw', isa => 'Bool', default => sub { 0 }, ); around 'bar' => sub { my $next = shift; my $self = shift; $self->test(1); $self->$next(); }; } my $foo = Foo::Extended->new; isa_ok($foo, 'Foo::Extended'); isa_ok($foo, 'Foo'); ok(!$foo->test, '... the test value has not been changed'); is($foo->baz, 'Bar::baz', '... got the right delegated method'); ok($foo->test, '... the test value has now been changed'); done_testing; override_and_foreign_classes.t100644000767000024 325112200352345 22121 0ustar00etherstaff000000000000Moose-2.1005/t/basics#!/usr/bin/perl use strict; use warnings; use Test::More; =pod This just tests the interaction of override/super with non-Moose superclasses. It really should not cause issues, the only thing it does is to create a metaclass for Foo so that it can find the right super method. This may end up being a sensitive issue for some non-Moose classes, but in 99% of the cases it should be just fine. =cut { package Foo; use strict; use warnings; sub new { bless {} => shift() } sub foo { 'Foo::foo' } sub bar { 'Foo::bar' } sub baz { 'Foo::baz' } package Bar; use Moose; extends 'Foo'; override bar => sub { 'Bar::bar -> ' . super() }; package Baz; use Moose; extends 'Bar'; override bar => sub { 'Baz::bar -> ' . super() }; override baz => sub { 'Baz::baz -> ' . super() }; } my $baz = Baz->new(); isa_ok($baz, 'Baz'); isa_ok($baz, 'Bar'); isa_ok($baz, 'Foo'); is($baz->foo(), 'Foo::foo', '... got the right value from &foo'); is($baz->bar(), 'Baz::bar -> Bar::bar -> Foo::bar', '... got the right value from &bar'); is($baz->baz(), 'Baz::baz -> Foo::baz', '... got the right value from &baz'); my $bar = Bar->new(); isa_ok($bar, 'Bar'); isa_ok($bar, 'Foo'); is($bar->foo(), 'Foo::foo', '... got the right value from &foo'); is($bar->bar(), 'Bar::bar -> Foo::bar', '... got the right value from &bar'); is($bar->baz(), 'Foo::baz', '... got the right value from &baz'); my $foo = Foo->new(); isa_ok($foo, 'Foo'); is($foo->foo(), 'Foo::foo', '... got the right value from &foo'); is($foo->bar(), 'Foo::bar', '... got the right value from &bar'); is($foo->baz(), 'Foo::baz', '... got the right value from &baz'); done_testing; override_augment_inner_super.t100644000767000024 277412200352345 22213 0ustar00etherstaff000000000000Moose-2.1005/t/basics#!/usr/bin/perl use strict; use warnings; use Test::More; { package Foo; use Moose; sub foo { 'Foo::foo(' . (inner() || '') . ')' }; sub bar { 'Foo::bar(' . (inner() || '') . ')' } package Bar; use Moose; extends 'Foo'; augment 'foo' => sub { 'Bar::foo' }; override 'bar' => sub { 'Bar::bar -> ' . super() }; package Baz; use Moose; extends 'Bar'; override 'foo' => sub { 'Baz::foo -> ' . super() }; augment 'bar' => sub { 'Baz::bar' }; } my $baz = Baz->new(); isa_ok($baz, 'Baz'); isa_ok($baz, 'Bar'); isa_ok($baz, 'Foo'); =pod Let em clarify what is happening here. Baz::foo is calling super(), which calls Bar::foo, which is an augmented sub that calls Foo::foo, then calls inner() which actually then calls Bar::foo. Confusing I know,.. but this is *exactly* what is it supposed to do :) =cut is($baz->foo, 'Baz::foo -> Foo::foo(Bar::foo)', '... got the right value from mixed augment/override foo'); =pod Allow me to clarify this one now ... Since Baz::bar is an augment routine, it needs to find the correct inner() to be called by. In this case it is Foo::bar. However, Bar::bar is in-between us, so it should actually be called first. Bar::bar is an overriden sub, and calls super() which in turn then calls our Foo::bar, which calls inner(), which calls Baz::bar. Confusing I know, but it is correct :) =cut is($baz->bar, 'Bar::bar -> Foo::bar(Baz::bar)', '... got the right value from mixed augment/override bar'); done_testing; instance_application_role_args.t100644000767000024 152212200352345 22151 0ustar00etherstaff000000000000Moose-2.1005/t/bugs#!/usr/bin/perl use strict; use warnings; use Test::More; { package Point; use Moose; with qw/DoesNegated DoesTranspose/; has x => ( isa => 'Int', is => 'rw' ); has y => ( isa => 'Int', is => 'rw' ); sub inspect { [$_[0]->x, $_[0]->y] } no Moose; } { package DoesNegated; use Moose::Role; sub negated { my $self = shift; $self->new( x => -$self->x, y => -$self->y ); } no Moose::Role; } { package DoesTranspose; use Moose::Role; sub transpose { my $self = shift; $self->new( x => $self->y, y => $self->x ); } no Moose::Role; } my $p = Point->new( x => 4, y => 3 ); DoesTranspose->meta->apply( $p, -alias => { transpose => 'negated' } ); is_deeply($p->negated->inspect, [3, 4]); is_deeply($p->transpose->inspect, [3, 4]); done_testing; native_trait_handles_bad_value.t100644000767000024 103112200352345 22111 0ustar00etherstaff000000000000Moose-2.1005/t/bugsuse strict; use warnings; use Test::More; use Test::Fatal; { package Bug; use Moose; ::like( ::exception{ has member => ( is => 'ro', isa => 'HashRef', traits => ['Hash'], handles => { method => sub { } }, ); }, qr/\QAll values passed to handles must be strings or ARRAY references, not CODE/, 'bad value in handles throws a useful error' ); } done_testing; metarole_w_metaclass_pm.t100644000767000024 551012200352345 22160 0ustar00etherstaff000000000000Moose-2.1005/t/metaclasses#!/usr/bin/perl use strict; use warnings; use Test::More; use Moose::Util::MetaRole; BEGIN { package My::Meta::Class; use Moose; extends 'Moose::Meta::Class'; } BEGIN { package My::Meta::Attribute; use Moose; extends 'Moose::Meta::Attribute'; } BEGIN { package My::Meta::Method; use Moose; extends 'Moose::Meta::Method'; } BEGIN { package My::Meta::Instance; use Moose; extends 'Moose::Meta::Instance'; } BEGIN { package Role::Foo; use Moose::Role; has 'foo' => ( is => 'ro', default => 10 ); } { package My::Class; use metaclass 'My::Meta::Class'; use Moose; } { package My::Class2; use metaclass 'My::Meta::Class' => ( attribute_metaclass => 'My::Meta::Attribute', method_metaclass => 'My::Meta::Method', instance_metaclass => 'My::Meta::Instance', ); use Moose; } { Moose::Util::MetaRole::apply_metaroles( for => 'My::Class', class_metaroles => { class => ['Role::Foo'] }, ); ok( My::Class->meta()->meta()->does_role('Role::Foo'), 'apply Role::Foo to My::Class->meta()' ); has_superclass( My::Class->meta(), 'My::Meta::Class', 'apply_metaroles works with metaclass.pm' ); } { Moose::Util::MetaRole::apply_metaroles( for => 'My::Class2', class_metaroles => { attribute => ['Role::Foo'], method => ['Role::Foo'], instance => ['Role::Foo'], }, ); ok( My::Class2->meta()->attribute_metaclass()->meta()->does_role('Role::Foo'), q{apply Role::Foo to My::Class2->meta()'s attribute metaclass} ); has_superclass( My::Class2->meta()->attribute_metaclass(), 'My::Meta::Attribute', '... and this does not interfere with attribute metaclass set via metaclass.pm' ); ok( My::Class2->meta()->method_metaclass()->meta()->does_role('Role::Foo'), q{apply Role::Foo to My::Class2->meta()'s method metaclass} ); has_superclass( My::Class2->meta()->method_metaclass(), 'My::Meta::Method', '... and this does not interfere with method metaclass set via metaclass.pm' ); ok( My::Class2->meta()->instance_metaclass()->meta()->does_role('Role::Foo'), q{apply Role::Foo to My::Class2->meta()'s instance metaclass} ); has_superclass( My::Class2->meta()->instance_metaclass(), 'My::Meta::Instance', '... and this does not interfere with instance metaclass set via metaclass.pm' ); } # like isa_ok but works with a class name, not just refs sub has_superclass { my $thing = shift; my $parent = shift; my $desc = shift; my %supers = map { $_ => 1 } $thing->meta()->superclasses(); local $Test::Builder::Level = $Test::Builder::Level + 1; ok( $supers{$parent}, $desc ); } done_testing; collection_with_roles.t100644000767000024 422112200352345 22232 0ustar00etherstaff000000000000Moose-2.1005/t/native_traits#!/usr/bin/perl use strict; use warnings; use Test::More; { package Subject; use Moose::Role; has observers => ( traits => ['Array'], is => 'ro', isa => 'ArrayRef[Observer]', auto_deref => 1, default => sub { [] }, handles => { 'add_observer' => 'push', 'count_observers' => 'count', }, ); sub notify { my ($self) = @_; foreach my $observer ( $self->observers() ) { $observer->update($self); } } } { package Observer; use Moose::Role; requires 'update'; } { package Counter; use Moose; with 'Subject'; has count => ( traits => ['Counter'], is => 'ro', isa => 'Int', default => 0, handles => { inc_counter => 'inc', dec_counter => 'dec', }, ); after qw(inc_counter dec_counter) => sub { my ($self) = @_; $self->notify(); }; } { package Display; use Test::More; use Moose; with 'Observer'; sub update { my ( $self, $subject ) = @_; like $subject->count, qr{^-?\d+$}, 'Observed number ' . $subject->count; } } package main; my $count = Counter->new(); ok( $count->can('add_observer'), 'add_observer method added' ); ok( $count->can('count_observers'), 'count_observers method added' ); ok( $count->can('inc_counter'), 'inc_counter method added' ); ok( $count->can('dec_counter'), 'dec_counter method added' ); $count->add_observer( Display->new() ); is( $count->count_observers, 1, 'Only one observer' ); is( $count->count, 0, 'Default to zero' ); $count->inc_counter; is( $count->count, 1, 'Increment to one ' ); $count->inc_counter for ( 1 .. 6 ); is( $count->count, 7, 'Increment up to seven' ); $count->dec_counter; is( $count->count, 6, 'Decrement to 6' ); $count->dec_counter for ( 1 .. 5 ); is( $count->count, 1, 'Decrement to 1' ); $count->dec_counter for ( 1 .. 2 ); is( $count->count, -1, 'Negative numbers' ); $count->inc_counter; is( $count->count, 0, 'Back to zero' ); done_testing; custom_type_errors.t100644000767000024 332012200352345 22342 0ustar00etherstaff000000000000Moose-2.1005/t/type_constraints#!/usr/bin/perl use strict; use warnings; use Test::More; use Test::Fatal; { package Animal; use Moose; use Moose::Util::TypeConstraints; subtype 'Natural' => as 'Int' => where { $_ > 0 } => message {"This number ($_) is not a positive integer!"}; subtype 'NaturalLessThanTen' => as 'Natural' => where { $_ < 10 } => message {"This number ($_) is not less than ten!"}; has leg_count => ( is => 'rw', isa => 'NaturalLessThanTen', lazy => 1, default => 0, ); } is( exception { my $goat = Animal->new( leg_count => 4 ) }, undef, '... no errors thrown, value is good' ); is( exception { my $spider = Animal->new( leg_count => 8 ) }, undef, '... no errors thrown, value is good' ); like( exception { my $fern = Animal->new( leg_count => 0 ) }, qr/This number \(0\) is not less than ten!/, 'gave custom supertype error message on new' ); like( exception { my $centipede = Animal->new( leg_count => 30 ) }, qr/This number \(30\) is not less than ten!/, 'gave custom subtype error message on new' ); my $chimera; is( exception { $chimera = Animal->new( leg_count => 4 ) }, undef, '... no errors thrown, value is good' ); like( exception { $chimera->leg_count(0) }, qr/This number \(0\) is not less than ten!/, 'gave custom supertype error message on set to 0' ); like( exception { $chimera->leg_count(16) }, qr/This number \(16\) is not less than ten!/, 'gave custom subtype error message on set to 16' ); my $gimp = eval { Animal->new() }; is( $@, '', '... no errors thrown, value is good' ); like( exception { $gimp->leg_count }, qr/This number \(0\) is not less than ten!/, 'gave custom supertype error message on lazy set to 0' ); done_testing; union_is_a_type_of.t100644000767000024 241412200352345 22246 0ustar00etherstaff000000000000Moose-2.1005/t/type_constraints#!/usr/bin/perl use strict; use warnings; use Test::Fatal; use Test::More; use Moose::Util::TypeConstraints 'find_type_constraint'; use Moose::Meta::TypeConstraint::Union; my ( $item, $int, $classname, $num ) = map { find_type_constraint($_) } qw{Item Int ClassName Num}; ok( $int->is_subtype_of($item), 'Int is subtype of Item' ); ok( $classname->is_subtype_of($item), 'ClassName is subtype of Item' ); ok( ( not $int->is_subtype_of($classname) ), 'Int is not subtype of ClassName' ); ok( ( not $classname->is_subtype_of($int) ), 'ClassName is not subtype of Int' ); my $union = Moose::Meta::TypeConstraint::Union->new( type_constraints => [ $int, $classname ] ); my @domain_values = qw( 85439 Moose::Meta::TypeConstraint ); is( exception { $union->assert_valid($_) }, undef, qq{Union accepts "$_".} ) for @domain_values; ok( $union->is_subtype_of( find_type_constraint($_) ), "Int|ClassName is a subtype of $_" ) for qw{Item Defined Value Str}; ok( ( not $union->is_subtype_of( find_type_constraint($_) ) ), "Int|ClassName is not a subtype of $_" ) for qw{Num Int ClassName}; ok( ( not $union->is_a_type_of( find_type_constraint($_) ) ), "Int|ClassName is not a type of $_" ) for qw{Int ClassName}; done_testing; util_type_coercion.t100644000767000024 467112200352345 22304 0ustar00etherstaff000000000000Moose-2.1005/t/type_constraints#!/usr/bin/perl use strict; use warnings; use Test::More; use Test::Fatal; use Moose::Util::TypeConstraints; { package HTTPHeader; use Moose; has 'array' => (is => 'ro'); has 'hash' => (is => 'ro'); } subtype Header => => as Object => where { $_->isa('HTTPHeader') }; coerce Header => from ArrayRef => via { HTTPHeader->new(array => $_[0]) } => from HashRef => via { HTTPHeader->new(hash => $_[0]) }; Moose::Util::TypeConstraints->export_type_constraints_as_functions(); my $header = HTTPHeader->new(); isa_ok($header, 'HTTPHeader'); ok(Header($header), '... this passed the type test'); ok(!Header([]), '... this did not pass the type test'); ok(!Header({}), '... this did not pass the type test'); my $anon_type = subtype Object => where { $_->isa('HTTPHeader') }; is( exception { coerce $anon_type => from ArrayRef => via { HTTPHeader->new(array => $_[0]) } => from HashRef => via { HTTPHeader->new(hash => $_[0]) }; }, undef, 'coercion of anonymous subtype succeeds' ); foreach my $coercion ( find_type_constraint('Header')->coercion, $anon_type->coercion ) { isa_ok($coercion, 'Moose::Meta::TypeCoercion'); { my $coerced = $coercion->coerce([ 1, 2, 3 ]); isa_ok($coerced, 'HTTPHeader'); is_deeply( $coerced->array(), [ 1, 2, 3 ], '... got the right array'); is($coerced->hash(), undef, '... nothing assigned to the hash'); } { my $coerced = $coercion->coerce({ one => 1, two => 2, three => 3 }); isa_ok($coerced, 'HTTPHeader'); is_deeply( $coerced->hash(), { one => 1, two => 2, three => 3 }, '... got the right hash'); is($coerced->array(), undef, '... nothing assigned to the array'); } { my $scalar_ref = \(my $var); my $coerced = $coercion->coerce($scalar_ref); is($coerced, $scalar_ref, '... got back what we put in'); } { my $coerced = $coercion->coerce("Foo"); is($coerced, "Foo", '... got back what we put in'); } } subtype 'StrWithTrailingX' => as 'Str' => where { /X$/ }; coerce 'StrWithTrailingX' => from 'Str' => via { $_ . 'X' }; my $tc = find_type_constraint('StrWithTrailingX'); is($tc->coerce("foo"), "fooX", "coerce when needed"); is($tc->coerce("fooX"), "fooX", "do not coerce when unneeded"); done_testing; meta_labeled_attributetrait.t100644000767000024 267212200352345 22153 0ustar00etherstaff000000000000Moose-2.1005/t/recipes#!/usr/bin/perl -w use strict; use Test::More 'no_plan'; use Test::Fatal; $| = 1; # =begin testing SETUP { package MyApp::Meta::Attribute::Trait::Labeled; use Moose::Role; Moose::Util::meta_attribute_alias('Labeled'); has label => ( is => 'rw', isa => 'Str', predicate => 'has_label', ); package MyApp::Website; use Moose; has url => ( traits => [qw/Labeled/], is => 'rw', isa => 'Str', label => "The site's URL", ); has name => ( is => 'rw', isa => 'Str', ); sub dump { my $self = shift; my $meta = $self->meta; my $dump = ''; for my $attribute ( map { $meta->get_attribute($_) } sort $meta->get_attribute_list ) { if ( $attribute->does('MyApp::Meta::Attribute::Trait::Labeled') && $attribute->has_label ) { $dump .= $attribute->label; } else { $dump .= $attribute->name; } my $reader = $attribute->get_read_method; $dump .= ": " . $self->$reader . "\n"; } return $dump; } package main; my $app = MyApp::Website->new( url => "http://google.com", name => "Google" ); } # =begin testing { my $app = MyApp::Website->new( url => 'http://google.com', name => 'Google' ); is( $app->dump, q{name: Google The site's URL: http://google.com }, '... got the expected dump value' ); } 1; roles_applicationtoinstance.t100644000767000024 335012200352345 22217 0ustar00etherstaff000000000000Moose-2.1005/t/recipes#!/usr/bin/perl -w use strict; use Test::More 'no_plan'; use Test::Fatal; $| = 1; # =begin testing SETUP { # Not in the recipe, but needed for writing tests. package Employee; use Moose; has 'name' => ( is => 'ro', isa => 'Str', required => 1, ); has 'work' => ( is => 'rw', isa => 'Str', predicate => 'has_work', ); } # =begin testing SETUP { package MyApp::Role::Job::Manager; use List::Util qw( first ); use Moose::Role; has 'employees' => ( is => 'rw', isa => 'ArrayRef[Employee]', ); sub assign_work { my $self = shift; my $work = shift; my $employee = first { !$_->has_work } @{ $self->employees }; die 'All my employees have work to do!' unless $employee; $employee->work($work); } package main; my $lisa = Employee->new( name => 'Lisa' ); MyApp::Role::Job::Manager->meta->apply($lisa); my $homer = Employee->new( name => 'Homer' ); my $bart = Employee->new( name => 'Bart' ); my $marge = Employee->new( name => 'Marge' ); $lisa->employees( [ $homer, $bart, $marge ] ); $lisa->assign_work('mow the lawn'); } # =begin testing { { my $lisa = Employee->new( name => 'Lisa' ); MyApp::Role::Job::Manager->meta->apply($lisa); my $homer = Employee->new( name => 'Homer' ); my $bart = Employee->new( name => 'Bart' ); my $marge = Employee->new( name => 'Marge' ); $lisa->employees( [ $homer, $bart, $marge ] ); $lisa->assign_work('mow the lawn'); ok( $lisa->does('MyApp::Role::Job::Manager'), 'lisa now does the manager role' ); is( $homer->work, 'mow the lawn', 'homer was assigned a task by lisa' ); } } 1; ClassEncapsulatedAttributes.pod100644000767000024 710612200352345 22330 0ustar00etherstaff000000000000Moose-2.1005/examples package # hide the package from PAUSE ClassEncapsulatedAttributes; use strict; use warnings; our $VERSION = '0.06'; use base 'Class::MOP::Class'; sub initialize { (shift)->SUPER::initialize(@_, # use the custom attribute metaclass here 'attribute_metaclass' => 'ClassEncapsulatedAttributes::Attribute', ); } sub construct_instance { my ($class, %params) = @_; my $meta_instance = $class->get_meta_instance; my $instance = $meta_instance->create_instance(); # initialize *ALL* attributes, including masked ones (as opposed to applicable) foreach my $current_class ($class->class_precedence_list()) { my $meta = $current_class->meta; foreach my $attr_name ($meta->get_attribute_list()) { my $attr = $meta->get_attribute($attr_name); $attr->initialize_instance_slot($meta_instance, $instance, \%params); } } return $instance; } package # hide the package from PAUSE ClassEncapsulatedAttributes::Attribute; use strict; use warnings; our $VERSION = '0.04'; use base 'Class::MOP::Attribute'; # alter the way parameters are specified sub initialize_instance_slot { my ($self, $meta_instance, $instance, $params) = @_; # if the attr has an init_arg, use that, otherwise, # use the attributes name itself as the init_arg my $init_arg = $self->init_arg(); # try to fetch the init arg from the %params ... my $class = $self->associated_class; my $val; $val = $params->{$class->name}->{$init_arg} if exists $params->{$class->name} && exists ${$params->{$class->name}}{$init_arg}; # if nothing was in the %params, we can use the # attribute's default value (if it has one) if (!defined $val && $self->has_default) { $val = $self->default($instance); } # now add this to the instance structure $meta_instance->set_slot_value($instance, $self->name, $val); } sub name { my $self = shift; return ($self->associated_class->name . '::' . $self->SUPER::name) } 1; __END__ =pod =head1 NAME ClassEncapsulatedAttributes - A set of example metaclasses with class encapsulated attributes =head1 SYNOPSIS package Foo; use metaclass 'ClassEncapsulatedAttributes'; Foo->meta->add_attribute('foo' => ( accessor => 'Foo_foo', default => 'init in FOO' )); sub new { my $class = shift; $class->meta->new_object(@_); } package Bar; our @ISA = ('Foo'); # duplicate the attribute name here Bar->meta->add_attribute('foo' => ( accessor => 'Bar_foo', default => 'init in BAR' )); # ... later in other code ... my $bar = Bar->new(); prints $bar->Bar_foo(); # init in BAR prints $bar->Foo_foo(); # init in FOO # and ... my $bar = Bar->new( 'Foo' => { 'foo' => 'Foo::foo' }, 'Bar' => { 'foo' => 'Bar::foo' } ); prints $bar->Bar_foo(); # Foo::foo prints $bar->Foo_foo(); # Bar::foo =head1 DESCRIPTION This is an example metaclass which encapsulates a class's attributes on a per-class basis. This means that there is no possibility of name clashes with inherited attributes. This is similar to how C++ handles its data members. =head1 ACKNOWLEDGEMENTS Thanks to Yuval "nothingmuch" Kogman for the idea for this example. =head1 AUTHORS Stevan Little Estevan@iinteractive.comE Yuval Kogman Enothingmuch@woobling.comE =head1 COPYRIGHT AND LICENSE Copyright 2006-2008 by Infinity Interactive, Inc. L This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut Native000755000767000024 012200352345 20104 5ustar00etherstaff000000000000Moose-2.1005/lib/Moose/Meta/AttributeTrait.pm100644000767000024 1525412200352345 21714 0ustar00etherstaff000000000000Moose-2.1005/lib/Moose/Meta/Attribute/Native package Moose::Meta::Attribute::Native::Trait; BEGIN { $Moose::Meta::Attribute::Native::Trait::AUTHORITY = 'cpan:STEVAN'; } { $Moose::Meta::Attribute::Native::Trait::VERSION = '2.1005'; } use Moose::Role; use Class::Load qw(load_class); use List::MoreUtils qw( any uniq ); use Moose::Deprecated; use Moose::Util; use Moose::Util::TypeConstraints; requires '_helper_type'; has _used_default_is => ( is => 'rw', isa => 'Bool', default => 0, ); before '_process_options' => sub { my ( $self, $name, $options ) = @_; $self->_check_helper_type( $options, $name ); if ( !( any { exists $options->{$_} } qw( is reader writer accessor ) ) && $self->can('_default_is') ) { $options->{is} = $self->_default_is; $options->{_used_default_is} = 1; } if ( !( $options->{required} || any { exists $options->{$_} } qw( default builder lazy_build ) ) && $self->can('_default_default') ) { $options->{default} = $self->_default_default; Moose::Deprecated::deprecated( feature => 'default default for Native Trait', message => 'Allowing a native trait to automatically supply a default is deprecated.' . ' You can avoid this warning by supplying a default, builder, or making the attribute required' ); } }; after 'install_accessors' => sub { my $self = shift; return unless $self->_used_default_is; my @methods = $self->_default_is eq 'rw' ? qw( reader writer accessor ) : 'reader'; my $name = $self->name; my $class = $self->associated_class->name; for my $meth ( uniq grep {defined} map { $self->$_ } @methods ) { my $message = "The $meth method in the $class class was automatically created" . " by the native delegation trait for the $name attribute." . q{ This "default is" feature is deprecated.} . q{ Explicitly set "is" or define accessor names to avoid this}; $self->associated_class->add_before_method_modifier( $meth => sub { Moose::Deprecated::deprecated( feature => 'default is for Native Trait', message =>$message, ); } ); } }; sub _check_helper_type { my ( $self, $options, $name ) = @_; my $type = $self->_helper_type; $options->{isa} = $type unless exists $options->{isa}; my $isa; my $isa_name; if ( Moose::Util::does_role( $options->{isa}, 'Specio::Constraint::Role::Interface' ) ) { $isa = $options->{isa}; require Specio::Library::Builtins; return if $isa->is_a_type_of( Specio::Library::Builtins::t($type) ); $isa_name = $isa->name() || $isa->description(); } else { $isa = Moose::Util::TypeConstraints::find_or_create_type_constraint( $options->{isa} ); return if $isa->is_a_type_of($type); $isa_name = $isa->name(); } confess "The type constraint for $name must be a subtype of $type but it's a $isa_name"; } before 'install_accessors' => sub { (shift)->_check_handles_values }; sub _check_handles_values { my $self = shift; my %handles = $self->_canonicalize_handles; for my $original_method ( values %handles ) { my $name = $original_method->[0]; my $accessor_class = $self->_native_accessor_class_for($name); ( $accessor_class && $accessor_class->can('new') ) || confess "$name is an unsupported method type - $accessor_class"; } } around '_canonicalize_handles' => sub { shift; my $self = shift; my $handles = $self->handles; return unless $handles; unless ( 'HASH' eq ref $handles ) { $self->throw_error( "The 'handles' option must be a HASH reference, not $handles"); } return map { $_ => $self->_canonicalize_handles_value( $handles->{$_} ) } keys %$handles; }; sub _canonicalize_handles_value { my $self = shift; my $value = shift; if ( ref $value && 'ARRAY' ne ref $value ) { $self->throw_error( "All values passed to handles must be strings or ARRAY references, not $value" ); } return ref $value ? $value : [$value]; } around '_make_delegation_method' => sub { my $next = shift; my ( $self, $handle_name, $method_to_call ) = @_; my ( $name, @curried_args ) = @$method_to_call; my $accessor_class = $self->_native_accessor_class_for($name); die "Cannot find an accessor class for $name" unless $accessor_class && $accessor_class->can('new'); return $accessor_class->new( name => $handle_name, package_name => $self->associated_class->name, delegate_to_method => $name, attribute => $self, is_inline => 1, curried_arguments => \@curried_args, root_types => [ $self->_root_types ], ); }; sub _root_types { return $_[0]->_helper_type; } sub _native_accessor_class_for { my ( $self, $suffix ) = @_; my $role = 'Moose::Meta::Method::Accessor::Native::' . $self->_native_type . '::' . $suffix; load_class($role); return Moose::Meta::Class->create_anon_class( superclasses => [ $self->accessor_metaclass, $self->delegation_metaclass ], roles => [$role], cache => 1, )->name; } sub _build_native_type { my $self = shift; for my $role_name ( map { $_->name } $self->meta->calculate_all_roles ) { return $1 if $role_name =~ /::Native::Trait::(\w+)$/; } die "Cannot calculate native type for " . ref $self; } has '_native_type' => ( is => 'ro', isa => 'Str', lazy => 1, builder => '_build_native_type', ); no Moose::Role; no Moose::Util::TypeConstraints; 1; # ABSTRACT: Shared role for native delegation traits __END__ =pod =head1 NAME Moose::Meta::Attribute::Native::Trait - Shared role for native delegation traits =head1 VERSION version 2.1005 =head1 BUGS See L for details on reporting bugs. =head1 SEE ALSO Documentation for Moose native traits can be found in L. =head1 AUTHOR Moose is maintained by the Moose Cabal, along with the help of many contributors. See L and L for details. =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2013 by Infinity Interactive, Inc.. This is free software; you can redistribute it and/or modify it under the same terms as the Perl 5 programming language system itself. =cut Accessor000755000767000024 012200352345 17675 5ustar00etherstaff000000000000Moose-2.1005/lib/Moose/Meta/MethodNative.pm100644000767000024 755412200352345 21634 0ustar00etherstaff000000000000Moose-2.1005/lib/Moose/Meta/Method/Accessorpackage Moose::Meta::Method::Accessor::Native; BEGIN { $Moose::Meta::Method::Accessor::Native::AUTHORITY = 'cpan:STEVAN'; } { $Moose::Meta::Method::Accessor::Native::VERSION = '2.1005'; } use strict; use warnings; use Carp qw( confess ); use Scalar::Util qw( blessed weaken ); use Moose::Role; around new => sub { my $orig = shift; my $class = shift; my %options = @_; $options{curried_arguments} = [] unless exists $options{curried_arguments}; confess 'You must supply a curried_arguments which is an ARRAY reference' unless $options{curried_arguments} && ref($options{curried_arguments}) eq 'ARRAY'; my $attr_context = $options{attribute}->definition_context; my $desc = 'native delegation method '; $desc .= $options{attribute}->associated_class->name; $desc .= '::' . $options{name}; $desc .= " ($options{delegate_to_method})"; $desc .= " of attribute " . $options{attribute}->name; $options{definition_context} = { %{ $attr_context || {} }, description => $desc, }; $options{accessor_type} = 'native'; return $class->$orig(%options); }; sub _new { my $class = shift; my $options = @_ == 1 ? $_[0] : {@_}; return bless $options, $class; } sub root_types { (shift)->{'root_types'} } sub _initialize_body { my $self = shift; $self->{'body'} = $self->_compile_code( [$self->_generate_method] ); return; } sub _inline_curried_arguments { my $self = shift; return unless @{ $self->curried_arguments }; return 'unshift @_, @curried;'; } sub _inline_check_argument_count { my $self = shift; my @code; if (my $min = $self->_minimum_arguments) { push @code, ( 'if (@_ < ' . $min . ') {', $self->_inline_throw_error( sprintf( '"Cannot call %s without at least %s argument%s"', $self->delegate_to_method, $min, ($min == 1 ? '' : 's'), ) ) . ';', '}', ); } if (defined(my $max = $self->_maximum_arguments)) { push @code, ( 'if (@_ > ' . $max . ') {', $self->_inline_throw_error( sprintf( '"Cannot call %s with %s argument%s"', $self->delegate_to_method, $max ? "more than $max" : 'any', ($max == 1 ? '' : 's'), ) ) . ';', '}', ); } return @code; } sub _inline_return_value { my $self = shift; my ($slot_access, $for_writer) = @_; return 'return ' . $self->_return_value($slot_access, $for_writer) . ';'; } sub _minimum_arguments { 0 } sub _maximum_arguments { undef } override _get_value => sub { my $self = shift; my ($instance) = @_; return $self->_slot_access_can_be_inlined ? super() : $instance . '->$reader'; }; override _inline_store_value => sub { my $self = shift; my ($instance, $value) = @_; return $self->_slot_access_can_be_inlined ? super() : $instance . '->$writer(' . $value . ');'; }; override _eval_environment => sub { my $self = shift; my $env = super(); $env->{'@curried'} = $self->curried_arguments; return $env if $self->_slot_access_can_be_inlined; my $reader = $self->associated_attribute->get_read_method_ref; $reader = $reader->body if blessed $reader; $env->{'$reader'} = \$reader; my $writer = $self->associated_attribute->get_write_method_ref; $writer = $writer->body if blessed $writer; $env->{'$writer'} = \$writer; return $env; }; sub _slot_access_can_be_inlined { my $self = shift; return $self->is_inline && $self->_instance_is_inlinable; } no Moose::Role; 1; apply_role_to_one_instance_only.t100644000767000024 152012200352345 22361 0ustar00etherstaff000000000000Moose-2.1005/t/bugs#!/usr/bin/perl use strict; use warnings; use Test::More; use Test::Fatal; { package MyRole1; use Moose::Role; sub a_role_method { 'foo' } } { package MyRole2; use Moose::Role; # empty } { package Foo; use Moose; } my $instance_with_role1 = Foo->new; MyRole1->meta->apply($instance_with_role1); my $instance_with_role2 = Foo->new; MyRole2->meta->apply($instance_with_role2); ok ((not $instance_with_role2->does('MyRole1')), 'instance does not have the wrong role'); ok ((not $instance_with_role2->can('a_role_method')), 'instance does not have methods from the wrong role'); ok (($instance_with_role1->does('MyRole1')), 'role was applied to the correct instance'); is( exception { is $instance_with_role1->a_role_method, 'foo' }, undef, 'instance has correct role method' ); done_testing; attribute_errors_and_edge_cases.t100644000767000024 1353012200352345 22330 0ustar00etherstaff000000000000Moose-2.1005/t/cmopuse strict; use warnings; use Test::More; use Test::Fatal; use Class::MOP; use Class::MOP::Attribute; # most values are static { isnt( exception { Class::MOP::Attribute->new('$test' => ( default => qr/hello (.*)/ )); }, undef, '... no refs for defaults' ); isnt( exception { Class::MOP::Attribute->new('$test' => ( default => [] )); }, undef, '... no refs for defaults' ); isnt( exception { Class::MOP::Attribute->new('$test' => ( default => {} )); }, undef, '... no refs for defaults' ); isnt( exception { Class::MOP::Attribute->new('$test' => ( default => \(my $var) )); }, undef, '... no refs for defaults' ); isnt( exception { Class::MOP::Attribute->new('$test' => ( default => bless {} => 'Foo' )); }, undef, '... no refs for defaults' ); } { isnt( exception { Class::MOP::Attribute->new('$test' => ( builder => qr/hello (.*)/ )); }, undef, '... no refs for builders' ); isnt( exception { Class::MOP::Attribute->new('$test' => ( builder => [] )); }, undef, '... no refs for builders' ); isnt( exception { Class::MOP::Attribute->new('$test' => ( builder => {} )); }, undef, '... no refs for builders' ); isnt( exception { Class::MOP::Attribute->new('$test' => ( builder => \(my $var) )); }, undef, '... no refs for builders' ); isnt( exception { Class::MOP::Attribute->new('$test' => ( builder => bless {} => 'Foo' )); }, undef, '... no refs for builders' ); isnt( exception { Class::MOP::Attribute->new('$test' => ( builder => 'Foo', default => 'Foo' )); }, undef, '... no default AND builder' ); my $undef_attr; is( exception { $undef_attr = Class::MOP::Attribute->new('$test' => ( default => undef, predicate => 'has_test', )); }, undef, '... undef as a default is okay' ); ok($undef_attr->has_default, '... and it counts as an actual default'); ok(!Class::MOP::Attribute->new('$test')->has_default, '... but attributes with no default have no default'); Class::MOP::Class->create( 'Foo', attributes => [$undef_attr], ); { my $obj = Foo->meta->new_object; ok($obj->has_test, '... and the default is populated'); is($obj->meta->get_attribute('$test')->get_value($obj), undef, '... with the right value'); } is( exception { Foo->meta->make_immutable }, undef, '... and it can be inlined' ); { my $obj = Foo->new; ok($obj->has_test, '... and the default is populated'); is($obj->meta->get_attribute('$test')->get_value($obj), undef, '... with the right value'); } } { # bad construtor args isnt( exception { Class::MOP::Attribute->new(); }, undef, '... no name argument' ); # These are no longer errors is( exception { Class::MOP::Attribute->new(''); }, undef, '... bad name argument' ); is( exception { Class::MOP::Attribute->new(0); }, undef, '... bad name argument' ); } { my $attr = Class::MOP::Attribute->new('$test'); isnt( exception { $attr->attach_to_class(); }, undef, '... attach_to_class died as expected' ); isnt( exception { $attr->attach_to_class('Fail'); }, undef, '... attach_to_class died as expected' ); isnt( exception { $attr->attach_to_class(bless {} => 'Fail'); }, undef, '... attach_to_class died as expected' ); } { my $attr = Class::MOP::Attribute->new('$test' => ( reader => [ 'whoops, this wont work' ] )); $attr->attach_to_class(Class::MOP::Class->initialize('Foo')); isnt( exception { $attr->install_accessors; }, undef, '... bad reader format' ); } { my $attr = Class::MOP::Attribute->new('$test'); isnt( exception { $attr->_process_accessors('fail', 'my_failing_sub'); }, undef, '... cannot find "fail" type generator' ); } { { package My::Attribute; our @ISA = ('Class::MOP::Attribute'); sub generate_reader_method { eval { die } } } my $attr = My::Attribute->new('$test' => ( reader => 'test' )); isnt( exception { $attr->install_accessors; }, undef, '... failed to generate accessors correctly' ); } { my $attr = Class::MOP::Attribute->new('$test' => ( predicate => 'has_test' )); my $Bar = Class::MOP::Class->create('Bar'); isa_ok($Bar, 'Class::MOP::Class'); $Bar->add_attribute($attr); can_ok('Bar', 'has_test'); is($attr, $Bar->remove_attribute('$test'), '... removed the $test attribute'); ok(!Bar->can('has_test'), '... Bar no longer has the "has_test" method'); } { # NOTE: # the next three tests once tested that # the code would fail, but we lifted the # restriction so you can have an accessor # along with a reader/writer pair (I mean # why not really). So now they test that # it works, which is kinda silly, but it # tests the API change, so I keep it. is( exception { Class::MOP::Attribute->new('$foo', ( accessor => 'foo', reader => 'get_foo', )); }, undef, '... can create accessors with reader/writers' ); is( exception { Class::MOP::Attribute->new('$foo', ( accessor => 'foo', writer => 'set_foo', )); }, undef, '... can create accessors with reader/writers' ); is( exception { Class::MOP::Attribute->new('$foo', ( accessor => 'foo', reader => 'get_foo', writer => 'set_foo', )); }, undef, '... can create accessors with reader/writers' ); } done_testing; instance_metaclass_incompat_dyn.t100644000767000024 305612200352345 22333 0ustar00etherstaff000000000000Moose-2.1005/t/cmopuse strict; use warnings; use Test::More; use metaclass; # meta classes { package Foo::Meta::Instance; use base 'Class::MOP::Instance'; package Bar::Meta::Instance; use base 'Class::MOP::Instance'; package FooBar::Meta::Instance; use base 'Foo::Meta::Instance', 'Bar::Meta::Instance'; } $@ = undef; eval { package Foo; metaclass->import('instance_metaclass' => 'Foo::Meta::Instance'); }; ok(!$@, '... Foo.meta => Foo::Meta is compatible') || diag $@; $@ = undef; eval { package Bar; metaclass->import('instance_metaclass' => 'Bar::Meta::Instance'); }; ok(!$@, '... Bar.meta => Bar::Meta is compatible') || diag $@; $@ = undef; eval { package Foo::Foo; metaclass->import('instance_metaclass' => 'Bar::Meta::Instance'); Foo::Foo->meta->superclasses('Foo'); }; ok($@, '... Foo::Foo.meta => Bar::Meta is not compatible') || diag $@; $@ = undef; eval { package Bar::Bar; metaclass->import('instance_metaclass' => 'Foo::Meta::Instance'); Bar::Bar->meta->superclasses('Bar'); }; ok($@, '... Bar::Bar.meta => Foo::Meta is not compatible') || diag $@; $@ = undef; eval { package FooBar; metaclass->import('instance_metaclass' => 'FooBar::Meta::Instance'); FooBar->meta->superclasses('Foo'); }; ok(!$@, '... FooBar.meta => FooBar::Meta is compatible') || diag $@; $@ = undef; eval { package FooBar2; metaclass->import('instance_metaclass' => 'FooBar::Meta::Instance'); FooBar2->meta->superclasses('Bar'); }; ok(!$@, '... FooBar2.meta => FooBar::Meta is compatible') || diag $@; done_testing; Custom000755000767000024 012200352345 20373 5ustar00etherstaff000000000000Moose-2.1005/t/lib/Moose/Meta/AttributeBar.pm100600000767000024 20112200352345 21536 0ustar00etherstaff000000000000Moose-2.1005/t/lib/Moose/Meta/Attribute/Custompackage Moose::Meta::Attribute::Custom::Bar; sub register_implementation { 'My::Bar' } package My::Bar; use Moose::Role; 1; Foo.pm100600000767000024 10312200352345 21556 0ustar00etherstaff000000000000Moose-2.1005/t/lib/Moose/Meta/Attribute/Custompackage Moose::Meta::Attribute::Custom::Foo; use Moose::Role; 1; custom_attr_meta_as_role.t100644000767000024 70112200352345 22325 0ustar00etherstaff000000000000Moose-2.1005/t/metaclasses#!/usr/bin/perl use strict; use warnings; use Test::More; use Test::Fatal; is( exception { package MooseX::Attribute::Test; use Moose::Role; }, undef, 'creating custom attribute "metarole" is okay' ); is( exception { package Moose::Meta::Attribute::Custom::Test; use Moose; extends 'Moose::Meta::Attribute'; with 'MooseX::Attribute::Test'; }, undef, 'custom attribute metaclass extending role is okay' ); done_testing; exporter_also_with_trait.t100644000767000024 115412200352345 22416 0ustar00etherstaff000000000000Moose-2.1005/t/metaclasses#!/usr/bin/env perl use strict; use warnings; use Test::More; use Test::Moose; BEGIN { package My::Meta::Role; use Moose::Role; $INC{'My/Meta/Role.pm'} = __FILE__; } BEGIN { package My::Exporter; use Moose::Exporter; Moose::Exporter->setup_import_methods( also => ['Moose'], class_metaroles => { class => ['My::Meta::Role'], }, ); $INC{'My/Exporter.pm'} = __FILE__; } { package My::Class; use My::Exporter; } { my $meta = My::Class->meta; isa_ok($meta, 'Moose::Meta::Class'); does_ok($meta, 'My::Meta::Role'); } done_testing; method_aliasing_in_composition.t100644000767000024 1303312200352345 22371 0ustar00etherstaff000000000000Moose-2.1005/t/roles#!/usr/bin/perl use strict; use warnings; use Test::More; use Test::Fatal; { package My::Role; use Moose::Role; sub foo { 'Foo::foo' } sub bar { 'Foo::bar' } sub baz { 'Foo::baz' } requires 'role_bar'; package My::Class; use Moose; ::is( ::exception { with 'My::Role' => { -alias => { bar => 'role_bar' } }; }, undef, '... this succeeds' ); package My::Class::Failure; use Moose; ::like( ::exception { with 'My::Role' => { -alias => { bar => 'role_bar' } }; }, qr/Cannot create a method alias if a local method of the same name exists/, '... this succeeds' ); sub role_bar { 'FAIL' } } ok(My::Class->meta->has_method($_), "we have a $_ method") for qw(foo baz bar role_bar); { package My::OtherRole; use Moose::Role; ::is( ::exception { with 'My::Role' => { -alias => { bar => 'role_bar' } }; }, undef, '... this succeeds' ); sub bar { 'My::OtherRole::bar' } package My::OtherRole::Failure; use Moose::Role; ::like( ::exception { with 'My::Role' => { -alias => { bar => 'role_bar' } }; }, qr/Cannot create a method alias if a local method of the same name exists/, '... cannot alias to a name that exists' ); sub role_bar { 'FAIL' } } ok(My::OtherRole->meta->has_method($_), "we have a $_ method") for qw(foo baz role_bar); ok(!My::OtherRole->meta->requires_method('bar'), '... and the &bar method is not required'); ok(!My::OtherRole->meta->requires_method('role_bar'), '... and the &role_bar method is not required'); { package My::AliasingRole; use Moose::Role; ::is( ::exception { with 'My::Role' => { -alias => { bar => 'role_bar' } }; }, undef, '... this succeeds' ); } ok(My::AliasingRole->meta->has_method($_), "we have a $_ method") for qw(foo baz role_bar); ok(!My::AliasingRole->meta->requires_method('bar'), '... and the &bar method is not required'); { package Foo::Role; use Moose::Role; sub foo { 'Foo::Role::foo' } package Bar::Role; use Moose::Role; sub foo { 'Bar::Role::foo' } package Baz::Role; use Moose::Role; sub foo { 'Baz::Role::foo' } package My::Foo::Class; use Moose; ::is( ::exception { with 'Foo::Role' => { -alias => { 'foo' => 'foo_foo' }, -excludes => 'foo' }, 'Bar::Role' => { -alias => { 'foo' => 'bar_foo' }, -excludes => 'foo' }, 'Baz::Role'; }, undef, '... composed our roles correctly' ); package My::Foo::Class::Broken; use Moose; ::like( ::exception { with 'Foo::Role' => { -alias => { 'foo' => 'foo_foo' }, -excludes => 'foo' }, 'Bar::Role' => { -alias => { 'foo' => 'foo_foo' }, -excludes => 'foo' }, 'Baz::Role'; }, qr/Due to a method name conflict in roles 'Bar::Role' and 'Foo::Role', the method 'foo_foo' must be implemented or excluded by 'My::Foo::Class::Broken'/, '... composed our roles correctly' ); } { my $foo = My::Foo::Class->new; isa_ok($foo, 'My::Foo::Class'); can_ok($foo, $_) for qw/foo foo_foo bar_foo/; is($foo->foo, 'Baz::Role::foo', '... got the right method'); is($foo->foo_foo, 'Foo::Role::foo', '... got the right method'); is($foo->bar_foo, 'Bar::Role::foo', '... got the right method'); } { package My::Foo::Role; use Moose::Role; ::is( ::exception { with 'Foo::Role' => { -alias => { 'foo' => 'foo_foo' }, -excludes => 'foo' }, 'Bar::Role' => { -alias => { 'foo' => 'bar_foo' }, -excludes => 'foo' }, 'Baz::Role'; }, undef, '... composed our roles correctly' ); } ok(My::Foo::Role->meta->has_method($_), "we have a $_ method") for qw/foo foo_foo bar_foo/;; ok(!My::Foo::Role->meta->requires_method('foo'), '... and the &foo method is not required'); { package My::Foo::Role::Other; use Moose::Role; ::is( ::exception { with 'Foo::Role' => { -alias => { 'foo' => 'foo_foo' }, -excludes => 'foo' }, 'Bar::Role' => { -alias => { 'foo' => 'foo_foo' }, -excludes => 'foo' }, 'Baz::Role'; }, undef, '... composed our roles correctly' ); } ok(!My::Foo::Role::Other->meta->has_method('foo_foo'), "we dont have a foo_foo method"); ok(My::Foo::Role::Other->meta->requires_method('foo_foo'), '... and the &foo method is required'); { package My::Foo::AliasOnly; use Moose; ::is( ::exception { with 'Foo::Role' => { -alias => { 'foo' => 'foo_foo' } }, }, undef, '... composed our roles correctly' ); } ok(My::Foo::AliasOnly->meta->has_method('foo'), 'we have a foo method'); ok(My::Foo::AliasOnly->meta->has_method('foo_foo'), '.. and the aliased foo_foo method'); { package Role::Foo; use Moose::Role; sub x1 {} sub y1 {} } { package Role::Bar; use Moose::Role; ::is( ::exception { with 'Role::Foo' => { -alias => { x1 => 'foo_x1' }, -excludes => ['y1'], }; }, undef, 'Compose Role::Foo into Role::Bar with alias and exclude' ); sub x1 {} sub y1 {} } { my $bar = Role::Bar->meta; ok( $bar->has_method($_), "has $_ method" ) for qw( x1 y1 foo_x1 ); } { package Role::Baz; use Moose::Role; ::is( ::exception { with 'Role::Foo' => { -alias => { x1 => 'foo_x1' }, -excludes => ['y1'], }; }, undef, 'Compose Role::Foo into Role::Baz with alias and exclude' ); } { my $baz = Role::Baz->meta; ok( $baz->has_method($_), "has $_ method" ) for qw( x1 foo_x1 ); ok( ! $baz->has_method('y1'), 'Role::Baz has no y1 method' ); } done_testing; match_type_operator.t100644000767000024 1461312200352345 22472 0ustar00etherstaff000000000000Moose-2.1005/t/type_constraints#!/usr/bin/perl use strict; use warnings; use Test::More; use Test::Fatal; use Moose::Util::TypeConstraints; # some simple type dispatching ... subtype 'Null' => as 'ArrayRef' => where { scalar @{$_} == 0 }; sub head { match_on_type @_ => Null => sub { die "Cannot get the head of Null" }, ArrayRef => sub { $_->[0] }; } sub tail { match_on_type @_ => Null => sub { die "Cannot get the tail of Null" }, ArrayRef => sub { [ @{ $_ }[ 1 .. $#{ $_ } ] ] }; } sub len { match_on_type @_ => Null => sub { 0 }, ArrayRef => sub { len( tail( $_ ) ) + 1 }; } sub rev { match_on_type @_ => Null => sub { [] }, ArrayRef => sub { [ @{ rev( tail( $_ ) ) }, head( $_ ) ] }; } is( len( [] ), 0, '... got the right length'); is( len( [ 1 ] ), 1, '... got the right length'); is( len( [ 1 .. 5 ] ), 5, '... got the right length'); is( len( [ 1 .. 50 ] ), 50, '... got the right length'); is_deeply( rev( [ 1 .. 5 ] ), [ reverse 1 .. 5 ], '... got the right reversed value' ); # break down a Maybe Type ... sub break_it_down { match_on_type shift, 'Maybe[Str]' => sub { match_on_type $_ => 'Undef' => sub { 'undef' }, 'Str' => sub { $_ } }, sub { 'default' } } is( break_it_down( 'FOO' ), 'FOO', '... got the right value'); is( break_it_down( [] ), 'default', '... got the right value'); is( break_it_down( undef ), 'undef', '... got the right value'); is( break_it_down(), 'undef', '... got the right value'); # checking against enum types enum RGB => qw[ red green blue ]; enum CMYK => qw[ cyan magenta yellow black ]; sub is_acceptable_color { match_on_type shift, 'RGB' => sub { 'RGB' }, 'CMYK' => sub { 'CMYK' }, sub { die "bad color $_" }; } is( is_acceptable_color( 'blue' ), 'RGB', '... got the right value'); is( is_acceptable_color( 'green' ), 'RGB', '... got the right value'); is( is_acceptable_color( 'red' ), 'RGB', '... got the right value'); is( is_acceptable_color( 'cyan' ), 'CMYK', '... got the right value'); is( is_acceptable_color( 'magenta' ), 'CMYK', '... got the right value'); is( is_acceptable_color( 'yellow' ), 'CMYK', '... got the right value'); is( is_acceptable_color( 'black' ), 'CMYK', '... got the right value'); isnt( exception { is_acceptable_color( 'orange' ) }, undef, '... got the exception' ); ## using it in an OO context { package LinkedList; use Moose; use Moose::Util::TypeConstraints; has 'next' => ( is => 'ro', isa => __PACKAGE__, lazy => 1, default => sub { __PACKAGE__->new }, predicate => 'has_next' ); sub pprint { my $list = shift; match_on_type $list => subtype( as 'LinkedList', where { ! $_->has_next } ) => sub { '[]' }, 'LinkedList' => sub { '[' . $_->next->pprint . ']' }; } } my $l = LinkedList->new; is($l->pprint, '[]', '... got the right pprint'); $l->next; is($l->pprint, '[[]]', '... got the right pprint'); $l->next->next; is($l->pprint, '[[[]]]', '... got the right pprint'); $l->next->next->next; is($l->pprint, '[[[[]]]]', '... got the right pprint'); # basic data dumper { package Foo; use Moose; sub to_string { 'Foo()' } } use B; sub ppprint { my $x = shift; match_on_type $x => HashRef => sub { my $hash = shift; '{ ' . (join ", " => map { $_ . ' => ' . ppprint( $hash->{ $_ } ) } sort keys %$hash ) . ' }' }, ArrayRef => sub { my $array = shift; '[ ' . (join ", " => map { ppprint( $_ ) } @$array ) . ' ]' }, CodeRef => sub { 'sub { ... }' }, RegexpRef => sub { 'qr/' . $_ . '/' }, GlobRef => sub { '*' . B::svref_2object($_)->NAME }, Object => sub { $_->can('to_string') ? $_->to_string : $_ }, ScalarRef => sub { '\\' . ppprint( ${$_} ) }, Num => sub { $_ }, Str => sub { '"'. $_ . '"' }, Undef => sub { 'undef' }, => sub { die "I don't know what $_ is" }; } # The stringification of qr// has changed in 5.13.5+ my $re_prefix = qr/x/ =~ /\(\?\^/ ? '(?^:' :'(?-xism:'; is( ppprint( { one => [ 1, 2, "three", 4, "five", \(my $x = "six") ], two => undef, three => sub { "OH HAI" }, four => qr/.*?/, five => \*ppprint, six => Foo->new, } ), qq~{ five => *ppprint, four => qr/$re_prefix.*?)/, one => [ 1, 2, "three", 4, "five", \\"six" ], six => Foo(), three => sub { ... }, two => undef }~, '... got the right pretty printed values' ); # simple JSON serializer sub to_json { my $x = shift; match_on_type $x => HashRef => sub { my $hash = shift; '{ ' . (join ", " => map { '"' . $_ . '" : ' . to_json( $hash->{ $_ } ) } sort keys %$hash ) . ' }' }, ArrayRef => sub { my $array = shift; '[ ' . (join ", " => map { to_json( $_ ) } @$array ) . ' ]' }, Num => sub { $_ }, Str => sub { '"'. $_ . '"' }, Undef => sub { 'null' }, => sub { die "$_ is not acceptable json type" }; } is( to_json( { one => 1, two => 2 } ), '{ "one" : 1, "two" : 2 }', '... got our valid JSON' ); is( to_json( { one => [ 1, 2, 3, 4 ], two => undef, three => "Hello World" } ), '{ "one" : [ 1, 2, 3, 4 ], "three" : "Hello World", "two" : null }', '... got our valid JSON' ); # some error cases sub not_enough_matches { my $x = shift; match_on_type $x => Undef => sub { 'hello undef world' }, CodeRef => sub { $_->('Hello code ref world') }; } like( exception { not_enough_matches( [] ) }, qr/No cases matched for /, '... not enough matches' ); done_testing; normalize_type_name.t100644000767000024 1114412200352345 22457 0ustar00etherstaff000000000000Moose-2.1005/t/type_constraints#!/usr/bin/perl use strict; use warnings; use Test::More; use Moose::Util::TypeConstraints; ## First, we check that the new regex parsing works ok Moose::Util::TypeConstraints::_detect_parameterized_type_constraint( 'ArrayRef[Str]') => 'detected correctly'; is_deeply [ Moose::Util::TypeConstraints::_parse_parameterized_type_constraint( 'ArrayRef[Str]') ], [ "ArrayRef", "Str" ] => 'Correctly parsed ArrayRef[Str]'; ok Moose::Util::TypeConstraints::_detect_parameterized_type_constraint( 'ArrayRef[Str ]') => 'detected correctly'; is_deeply [ Moose::Util::TypeConstraints::_parse_parameterized_type_constraint( 'ArrayRef[Str ]') ], [ "ArrayRef", "Str" ] => 'Correctly parsed ArrayRef[Str ]'; ok Moose::Util::TypeConstraints::_detect_parameterized_type_constraint( 'ArrayRef[ Str]') => 'detected correctly'; is_deeply [ Moose::Util::TypeConstraints::_parse_parameterized_type_constraint( 'ArrayRef[ Str]') ], [ "ArrayRef", "Str" ] => 'Correctly parsed ArrayRef[ Str]'; ok Moose::Util::TypeConstraints::_detect_parameterized_type_constraint( 'ArrayRef[ Str ]') => 'detected correctly'; is_deeply [ Moose::Util::TypeConstraints::_parse_parameterized_type_constraint( 'ArrayRef[ Str ]') ], [ "ArrayRef", "Str" ] => 'Correctly parsed ArrayRef[ Str ]'; ok Moose::Util::TypeConstraints::_detect_parameterized_type_constraint( 'ArrayRef[ HashRef[Int] ]') => 'detected correctly'; is_deeply [ Moose::Util::TypeConstraints::_parse_parameterized_type_constraint( 'ArrayRef[ HashRef[Int] ]') ], [ "ArrayRef", "HashRef[Int]" ] => 'Correctly parsed ArrayRef[ HashRef[Int] ]'; ok Moose::Util::TypeConstraints::_detect_parameterized_type_constraint( 'ArrayRef[ HashRef[Int ] ]') => 'detected correctly'; is_deeply [ Moose::Util::TypeConstraints::_parse_parameterized_type_constraint( 'ArrayRef[ HashRef[Int ] ]') ], [ "ArrayRef", "HashRef[Int ]" ] => 'Correctly parsed ArrayRef[ HashRef[Int ] ]'; ok Moose::Util::TypeConstraints::_detect_parameterized_type_constraint( 'ArrayRef[Int|Str]') => 'detected correctly'; is_deeply [ Moose::Util::TypeConstraints::_parse_parameterized_type_constraint( 'ArrayRef[Int|Str]') ], [ "ArrayRef", "Int|Str" ] => 'Correctly parsed ArrayRef[Int|Str]'; ok Moose::Util::TypeConstraints::_detect_parameterized_type_constraint( 'ArrayRef[ArrayRef[Int]|Str]') => 'detected correctly'; is_deeply [ Moose::Util::TypeConstraints::_parse_parameterized_type_constraint( 'ArrayRef[ArrayRef[Int]|Str]') ], [ "ArrayRef", "ArrayRef[Int]|Str" ] => 'Correctly parsed ArrayRef[ArrayRef[Int]|Str]'; ## creating names via subtype ok my $r = Moose::Util::TypeConstraints->get_type_constraint_registry => 'Got registry object'; ok my $subtype_a1 = subtype( 'subtype_a1' => as 'HashRef[Int]' ), => 'created subtype_a1'; ok my $subtype_a2 = subtype( 'subtype_a2' => as 'HashRef[ Int]' ), => 'created subtype_a2'; ok my $subtype_a3 = subtype( 'subtype_a2' => as 'HashRef[Int ]' ), => 'created subtype_a2'; ok my $subtype_a4 = subtype( 'subtype_a2' => as 'HashRef[ Int ]' ), => 'created subtype_a2'; is $subtype_a1->parent->name, $subtype_a2->parent->name => 'names match'; is $subtype_a1->parent->name, $subtype_a3->parent->name => 'names match'; is $subtype_a1->parent->name, $subtype_a4->parent->name => 'names match'; ok my $subtype_b1 = subtype( 'subtype_b1' => as 'HashRef[Int|Str]' ), => 'created subtype_b1'; ok my $subtype_b2 = subtype( 'subtype_b2' => as 'HashRef[Int | Str]' ), => 'created subtype_b2'; ok my $subtype_b3 = subtype( 'subtype_b3' => as 'HashRef[Str|Int]' ), => 'created subtype_b3'; is $subtype_b1->parent->name, $subtype_b2->parent->name => 'names match'; is $subtype_b1->parent->name, $subtype_b3->parent->name => 'names match'; is $subtype_b2->parent->name, $subtype_b3->parent->name => 'names match'; ## testing via add_constraint ok my $union1 = Moose::Util::TypeConstraints::create_type_constraint_union( 'ArrayRef[Int|Str] | ArrayRef[Int | HashRef]') => 'Created Union1'; ok my $union2 = Moose::Util::TypeConstraints::create_type_constraint_union( 'ArrayRef[ Int|Str] | ArrayRef[Int | HashRef]') => 'Created Union2'; ok my $union3 = Moose::Util::TypeConstraints::create_type_constraint_union( 'ArrayRef[Int |Str ] | ArrayRef[Int | HashRef ]') => 'Created Union3'; is $union1->name, $union2->name, 'names match'; is $union1->name, $union3->name, 'names match'; is $union2->name, $union3->name, 'names match'; done_testing; util_type_reloading.t100644000767000024 74412200352345 22424 0ustar00etherstaff000000000000Moose-2.1005/t/type_constraints#!/usr/bin/perl use strict; use warnings; use lib 't/lib', 'lib'; use Test::More; $SIG{__WARN__} = sub { 0 }; eval { require Foo; }; ok(!$@, '... loaded Foo successfully') || diag $@; delete $INC{'Foo.pm'}; eval { require Foo; }; ok(!$@, '... re-loaded Foo successfully') || diag $@; eval { require Bar; }; ok(!$@, '... loaded Bar successfully') || diag $@; delete $INC{'Bar.pm'}; eval { require Bar; }; ok(!$@, '... re-loaded Bar successfully') || diag $@; done_testing; Application000755000767000024 012200352345 20057 5ustar00etherstaff000000000000Moose-2.1005/lib/Moose/Meta/RoleToRole.pm100644000767000024 1566612200352345 22017 0ustar00etherstaff000000000000Moose-2.1005/lib/Moose/Meta/Role/Applicationpackage Moose::Meta::Role::Application::ToRole; BEGIN { $Moose::Meta::Role::Application::ToRole::AUTHORITY = 'cpan:STEVAN'; } { $Moose::Meta::Role::Application::ToRole::VERSION = '2.1005'; } use strict; use warnings; use metaclass; use Scalar::Util 'blessed'; use base 'Moose::Meta::Role::Application'; sub apply { my ($self, $role1, $role2) = @_; $self->SUPER::apply($role1, $role2); $role2->add_role($role1); } sub check_role_exclusions { my ($self, $role1, $role2) = @_; if ( $role2->excludes_role($role1->name) ) { require Moose; Moose->throw_error("Conflict detected: " . $role2->name . " excludes role '" . $role1->name . "'"); } foreach my $excluded_role_name ($role1->get_excluded_roles_list) { if ( $role2->does_role($excluded_role_name) ) { require Moose; Moose->throw_error("The role " . $role2->name . " does the excluded role '$excluded_role_name'"); } $role2->add_excluded_roles($excluded_role_name); } } sub check_required_methods { my ($self, $role1, $role2) = @_; foreach my $required_method ($role1->get_required_method_list) { my $required_method_name = $required_method->name; next if $self->is_aliased_method($required_method_name); $role2->add_required_methods($required_method) unless $role2->find_method_by_name($required_method_name); } } sub check_required_attributes { } sub apply_attributes { my ($self, $role1, $role2) = @_; foreach my $attribute_name ($role1->get_attribute_list) { # it if it has one already if ($role2->has_attribute($attribute_name) && # make sure we haven't seen this one already too $role2->get_attribute($attribute_name) != $role1->get_attribute($attribute_name)) { my $role2_name = $role2->name; require Moose; Moose->throw_error( "Role '" . $role1->name . "' has encountered an attribute conflict" . " while being composed into '$role2_name'." . " This is a fatal error and cannot be disambiguated." . " The conflicting attribute is named '$attribute_name'." ); } else { $role2->add_attribute( $role1->get_attribute($attribute_name)->clone ); } } } sub apply_methods { my ( $self, $role1, $role2 ) = @_; foreach my $method ( $role1->_get_local_methods ) { my $method_name = $method->name; next if $method->isa('Class::MOP::Method::Meta'); unless ( $self->is_method_excluded($method_name) ) { my $role2_method = $role2->get_method($method_name); if ( $role2_method && $role2_method->body != $method->body ) { # method conflicts between roles used to result in the method # becoming a requirement but now are permitted just like # for classes, hence no code in this branch anymore. } else { $role2->add_method( $method_name, $method, ); } } next unless $self->is_method_aliased($method_name); my $aliased_method_name = $self->get_method_aliases->{$method_name}; my $role2_method = $role2->get_method($aliased_method_name); if ( $role2_method && $role2_method->body != $method->body ) { require Moose; Moose->throw_error( "Cannot create a method alias if a local method of the same name exists" ); } $role2->add_method( $aliased_method_name, $role1->get_method($method_name) ); if ( !$role2->has_method($method_name) ) { $role2->add_required_methods($method_name) unless $self->is_method_excluded($method_name); } } } sub apply_override_method_modifiers { my ($self, $role1, $role2) = @_; foreach my $method_name ($role1->get_method_modifier_list('override')) { # it if it has one already then ... if ($role2->has_method($method_name)) { # if it is being composed into another role # we have a conflict here, because you cannot # combine an overridden method with a locally # defined one require Moose; Moose->throw_error("Role '" . $role1->name . "' has encountered an 'override' method conflict " . "during composition (A local method of the same name as been found). This " . "is fatal error."); } else { # if we are a role, we need to make sure # we don't have a conflict with the role # we are composing into if ($role2->has_override_method_modifier($method_name) && $role2->get_override_method_modifier($method_name) != $role2->get_override_method_modifier($method_name)) { require Moose; Moose->throw_error("Role '" . $role1->name . "' has encountered an 'override' method conflict " . "during composition (Two 'override' methods of the same name encountered). " . "This is fatal error."); } else { # if there is no conflict, # just add it to the role $role2->add_override_method_modifier( $method_name, $role1->get_override_method_modifier($method_name) ); } } } } sub apply_method_modifiers { my ($self, $modifier_type, $role1, $role2) = @_; my $add = "add_${modifier_type}_method_modifier"; my $get = "get_${modifier_type}_method_modifiers"; foreach my $method_name ($role1->get_method_modifier_list($modifier_type)) { $role2->$add( $method_name, $_ ) foreach $role1->$get($method_name); } } 1; # ABSTRACT: Compose a role into another role __END__ =pod =head1 NAME Moose::Meta::Role::Application::ToRole - Compose a role into another role =head1 VERSION version 2.1005 =head1 DESCRIPTION =head2 METHODS =over 4 =item B =item B =item B =item B =item B =item B =item B =item B =item B =item B =back =head1 BUGS See L for details on reporting bugs. =head1 AUTHOR Moose is maintained by the Moose Cabal, along with the help of many contributors. See L and L for details. =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2013 by Infinity Interactive, Inc.. This is free software; you can redistribute it and/or modify it under the same terms as the Perl 5 programming language system itself. =cut Conflicting.pm100644000767000024 377212200352345 22002 0ustar00etherstaff000000000000Moose-2.1005/lib/Moose/Meta/Role/Method package Moose::Meta::Role::Method::Conflicting; BEGIN { $Moose::Meta::Role::Method::Conflicting::AUTHORITY = 'cpan:STEVAN'; } { $Moose::Meta::Role::Method::Conflicting::VERSION = '2.1005'; } use strict; use warnings; use Moose::Util; use base qw(Moose::Meta::Role::Method::Required); __PACKAGE__->meta->add_attribute('roles' => ( reader => 'roles', required => 1, Class::MOP::_definition_context(), )); sub roles_as_english_list { my $self = shift; Moose::Util::english_list( map { q{'} . $_ . q{'} } @{ $self->roles } ); } 1; # ABSTRACT: A Moose metaclass for conflicting methods in Roles __END__ =pod =head1 NAME Moose::Meta::Role::Method::Conflicting - A Moose metaclass for conflicting methods in Roles =head1 VERSION version 2.1005 =head1 DESCRIPTION =head1 INHERITANCE C is a subclass of L. =head1 METHODS =over 4 =item B<< Moose::Meta::Role::Method::Conflicting->new(%options) >> This creates a new type constraint based on the provided C<%options>: =over 8 =item * name The method name. This is required. =item * roles The list of role names that generated the conflict. This is required. =back =item B<< $method->name >> Returns the conflicting method's name, as provided to the constructor. =item B<< $method->roles >> Returns the roles that generated this conflicting method, as provided to the constructor. =item B<< $method->roles_as_english_list >> Returns the roles that generated this conflicting method as an English list. =back =head1 BUGS See L for details on reporting bugs. =head1 AUTHOR Moose is maintained by the Moose Cabal, along with the help of many contributors. See L and L for details. =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2013 by Infinity Interactive, Inc.. This is free software; you can redistribute it and/or modify it under the same terms as the Perl 5 programming language system itself. =cut DuckType.pm100644000767000024 1024412200352345 22150 0ustar00etherstaff000000000000Moose-2.1005/lib/Moose/Meta/TypeConstraintpackage Moose::Meta::TypeConstraint::DuckType; BEGIN { $Moose::Meta::TypeConstraint::DuckType::AUTHORITY = 'cpan:STEVAN'; } { $Moose::Meta::TypeConstraint::DuckType::VERSION = '2.1005'; } use strict; use warnings; use metaclass; use B; use Scalar::Util 'blessed'; use List::MoreUtils qw(all); use Moose::Util 'english_list'; use Moose::Util::TypeConstraints (); use base 'Moose::Meta::TypeConstraint'; __PACKAGE__->meta->add_attribute('methods' => ( accessor => 'methods', Class::MOP::_definition_context(), )); my $inliner = sub { my $self = shift; my $val = shift; return $self->parent->_inline_check($val) . ' && do {' . "\n" . 'my $val = ' . $val . ';' . "\n" . '&List::MoreUtils::all(' . "\n" . 'sub { $val->can($_) },' . "\n" . join(', ', map { B::perlstring($_) } @{ $self->methods }) . ');' . "\n" . '}'; }; sub new { my ( $class, %args ) = @_; $args{parent} = Moose::Util::TypeConstraints::find_type_constraint('Object'); my @methods = @{ $args{methods} }; $args{constraint} = sub { my $val = $_[0]; return all { $val->can($_) } @methods; }; $args{inlined} = $inliner; my $self = $class->SUPER::new(\%args); $self->compile_type_constraint() unless $self->_has_compiled_type_constraint; return $self; } sub equals { my ( $self, $type_or_name ) = @_; my $other = Moose::Util::TypeConstraints::find_type_constraint($type_or_name); return unless $other->isa(__PACKAGE__); my @self_methods = sort @{ $self->methods }; my @other_methods = sort @{ $other->methods }; return unless @self_methods == @other_methods; while ( @self_methods ) { my $method = shift @self_methods; my $other_method = shift @other_methods; return unless $method eq $other_method; } return 1; } sub create_child_type { my ($self, @args) = @_; return Moose::Meta::TypeConstraint->new(@args, parent => $self); } sub get_message { my $self = shift; my ($value) = @_; if ($self->has_message) { return $self->SUPER::get_message(@_); } return $self->SUPER::get_message($value) unless blessed($value); my @methods = grep { !$value->can($_) } @{ $self->methods }; my $class = blessed $value; $class ||= $value; return $class . " is missing methods " . english_list(map { "'$_'" } @methods); } 1; # ABSTRACT: Type constraint for duck typing __END__ =pod =head1 NAME Moose::Meta::TypeConstraint::DuckType - Type constraint for duck typing =head1 VERSION version 2.1005 =head1 DESCRIPTION This class represents type constraints based on an enumerated list of required methods. =head1 INHERITANCE C is a subclass of L. =head1 METHODS =over 4 =item B<< Moose::Meta::TypeConstraint::DuckType->new(%options) >> This creates a new duck type constraint based on the given C<%options>. It takes the same options as its parent, with several exceptions. First, it requires an additional option, C. This should be an array reference containing a list of required method names. Second, it automatically sets the parent to the C type. Finally, it ignores any provided C option. The constraint is generated automatically based on the provided C. =item B<< $constraint->methods >> Returns the array reference of required methods provided to the constructor. =item B<< $constraint->create_child_type >> This returns a new L object with the type as its parent. Note that it does I return a C object! =back =head1 BUGS See L for details on reporting bugs. =head1 AUTHOR Moose is maintained by the Moose Cabal, along with the help of many contributors. See L and L for details. =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2013 by Infinity Interactive, Inc.. This is free software; you can redistribute it and/or modify it under the same terms as the Perl 5 programming language system itself. =cut Registry.pm100644000767000024 755612200352345 22224 0ustar00etherstaff000000000000Moose-2.1005/lib/Moose/Meta/TypeConstraint package Moose::Meta::TypeConstraint::Registry; BEGIN { $Moose::Meta::TypeConstraint::Registry::AUTHORITY = 'cpan:STEVAN'; } { $Moose::Meta::TypeConstraint::Registry::VERSION = '2.1005'; } use strict; use warnings; use metaclass; use Scalar::Util 'blessed'; use base 'Class::MOP::Object'; __PACKAGE__->meta->add_attribute('parent_registry' => ( reader => 'get_parent_registry', writer => 'set_parent_registry', predicate => 'has_parent_registry', Class::MOP::_definition_context(), )); __PACKAGE__->meta->add_attribute('type_constraints' => ( reader => 'type_constraints', default => sub { {} }, Class::MOP::_definition_context(), )); sub new { my $class = shift; my $self = $class->_new(@_); return $self; } sub has_type_constraint { my ($self, $type_name) = @_; ($type_name and exists $self->type_constraints->{$type_name}) ? 1 : 0 } sub get_type_constraint { my ($self, $type_name) = @_; return unless defined $type_name; $self->type_constraints->{$type_name} } sub add_type_constraint { my ($self, $type) = @_; unless ( $type && blessed $type && $type->isa('Moose::Meta::TypeConstraint') ) { require Moose; Moose->throw_error("No type supplied / type is not a valid type constraint"); } $self->type_constraints->{$type->name} = $type; } sub find_type_constraint { my ($self, $type_name) = @_; return $self->get_type_constraint($type_name) if $self->has_type_constraint($type_name); return $self->get_parent_registry->find_type_constraint($type_name) if $self->has_parent_registry; return; } 1; # ABSTRACT: registry for type constraints __END__ =pod =head1 NAME Moose::Meta::TypeConstraint::Registry - registry for type constraints =head1 VERSION version 2.1005 =head1 DESCRIPTION This class is a registry that maps type constraint names to L objects. Currently, it is only used internally by L, which creates a single global registry. =head1 INHERITANCE C is a subclass of L. =head1 METHODS =over 4 =item B<< Moose::Meta::TypeConstraint::Registry->new(%options) >> This creates a new registry object based on the provided C<%options>: =over 8 =item * parent_registry This is an optional L object. =item * type_constraints This is hash reference of type names to type objects. This is optional. Constraints can be added to the registry after it is created. =back =item B<< $registry->get_parent_registry >> Returns the registry's parent registry, if it has one. =item B<< $registry->has_parent_registry >> Returns true if the registry has a parent. =item B<< $registry->set_parent_registry($registry) >> Sets the parent registry. =item B<< $registry->get_type_constraint($type_name) >> This returns the L object from the registry for the given name, if one exists. =item B<< $registry->has_type_constraint($type_name) >> Returns true if the registry has a type of the given name. =item B<< $registry->add_type_constraint($type) >> Adds a new L object to the registry. =item B<< $registry->find_type_constraint($type_name) >> This method looks in the current registry for the named type. If the type is not found, then this method will look in the registry's parent, if it has one. =back =head1 BUGS See L for details on reporting bugs. =head1 AUTHOR Moose is maintained by the Moose Cabal, along with the help of many contributors. See L and L for details. =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2013 by Infinity Interactive, Inc.. This is free software; you can redistribute it and/or modify it under the same terms as the Perl 5 programming language system itself. =cut accessor_overwrite_warning.t100644000767000024 102312200352345 22604 0ustar00etherstaff000000000000Moose-2.1005/t/attributesuse strict; use warnings; use Test::More; use Test::Requires { 'Test::Output' => '0.01', }; { package Bar; use Moose; has has_attr => ( is => 'ro', ); ::stderr_like{ has attr => ( is => 'ro', predicate => 'has_attr', ) } qr/\QYou are overwriting an accessor (has_attr) for the has_attr attribute with a new accessor method for the attr attribute/, 'overwriting an accessor for another attribute causes a warning'; } done_testing; attribute_custom_metaclass.t100644000767000024 463012200352345 22607 0ustar00etherstaff000000000000Moose-2.1005/t/attributes#!/usr/bin/perl use strict; use warnings; use Test::More; use Test::Fatal; { package Foo::Meta::Attribute; use Moose; extends 'Moose::Meta::Attribute'; around 'new' => sub { my $next = shift; my $self = shift; my $name = shift; $next->($self, $name, (is => 'rw', isa => 'Foo'), @_); }; package Foo; use Moose; has 'foo' => (metaclass => 'Foo::Meta::Attribute'); } { my $foo = Foo->new; isa_ok($foo, 'Foo'); my $foo_attr = Foo->meta->get_attribute('foo'); isa_ok($foo_attr, 'Foo::Meta::Attribute'); isa_ok($foo_attr, 'Moose::Meta::Attribute'); is($foo_attr->name, 'foo', '... got the right name for our meta-attribute'); ok($foo_attr->has_accessor, '... our meta-attrubute created the accessor for us'); ok($foo_attr->has_type_constraint, '... our meta-attrubute created the type_constraint for us'); my $foo_attr_type_constraint = $foo_attr->type_constraint; isa_ok($foo_attr_type_constraint, 'Moose::Meta::TypeConstraint'); is($foo_attr_type_constraint->name, 'Foo', '... got the right type constraint name'); is($foo_attr_type_constraint->parent->name, 'Object', '... got the right type constraint parent name'); } { package Bar::Meta::Attribute; use Moose; extends 'Class::MOP::Attribute'; package Bar; use Moose; ::is( ::exception { has 'bar' => (metaclass => 'Bar::Meta::Attribute'); }, undef, '... the attribute metaclass need not be a Moose::Meta::Attribute as long as it behaves' ); } { package Moose::Meta::Attribute::Custom::Foo; sub register_implementation { 'Foo::Meta::Attribute' } package Moose::Meta::Attribute::Custom::Bar; use Moose; extends 'Moose::Meta::Attribute'; package Another::Foo; use Moose; ::is( ::exception { has 'foo' => (metaclass => 'Foo'); }, undef, '... the attribute metaclass alias worked correctly' ); ::is( ::exception { has 'bar' => (metaclass => 'Bar', is => 'bare'); }, undef, '... the attribute metaclass alias worked correctly' ); } { my $foo_attr = Another::Foo->meta->get_attribute('foo'); isa_ok($foo_attr, 'Foo::Meta::Attribute'); isa_ok($foo_attr, 'Moose::Meta::Attribute'); my $bar_attr = Another::Foo->meta->get_attribute('bar'); isa_ok($bar_attr, 'Moose::Meta::Attribute::Custom::Bar'); isa_ok($bar_attr, 'Moose::Meta::Attribute'); } done_testing; attribute_lazy_initializer.t100644000767000024 744212200352345 22627 0ustar00etherstaff000000000000Moose-2.1005/t/attributes#!/usr/bin/perl use strict; use warnings; use Test::More; use Test::Fatal; { package Foo; use Moose; has 'foo' => ( reader => 'get_foo', writer => 'set_foo', initializer => sub { my ($self, $value, $callback, $attr) = @_; ::isa_ok($attr, 'Moose::Meta::Attribute'); ::is($attr->name, 'foo', '... got the right name'); $callback->($value * 2); }, ); has 'lazy_foo' => ( reader => 'get_lazy_foo', lazy => 1, default => 10, initializer => sub { my ($self, $value, $callback, $attr) = @_; ::isa_ok($attr, 'Moose::Meta::Attribute'); ::is($attr->name, 'lazy_foo', '... got the right name'); $callback->($value * 2); }, ); has 'lazy_foo_w_type' => ( reader => 'get_lazy_foo_w_type', isa => 'Int', lazy => 1, default => 20, initializer => sub { my ($self, $value, $callback, $attr) = @_; ::isa_ok($attr, 'Moose::Meta::Attribute'); ::is($attr->name, 'lazy_foo_w_type', '... got the right name'); $callback->($value * 2); }, ); has 'lazy_foo_builder' => ( reader => 'get_lazy_foo_builder', builder => 'get_foo_builder', initializer => sub { my ($self, $value, $callback, $attr) = @_; ::isa_ok($attr, 'Moose::Meta::Attribute'); ::is($attr->name, 'lazy_foo_builder', '... got the right name'); $callback->($value * 2); }, ); has 'lazy_foo_builder_w_type' => ( reader => 'get_lazy_foo_builder_w_type', isa => 'Int', builder => 'get_foo_builder_w_type', initializer => sub { my ($self, $value, $callback, $attr) = @_; ::isa_ok($attr, 'Moose::Meta::Attribute'); ::is($attr->name, 'lazy_foo_builder_w_type', '... got the right name'); $callback->($value * 2); }, ); sub get_foo_builder { 100 } sub get_foo_builder_w_type { 1000 } } { my $foo = Foo->new(foo => 10); isa_ok($foo, 'Foo'); is($foo->get_foo, 20, 'initial value set to 2x given value'); is($foo->get_lazy_foo, 20, 'initial lazy value set to 2x given value'); is($foo->get_lazy_foo_w_type, 40, 'initial lazy value with type set to 2x given value'); is($foo->get_lazy_foo_builder, 200, 'initial lazy value with builder set to 2x given value'); is($foo->get_lazy_foo_builder_w_type, 2000, 'initial lazy value with builder and type set to 2x given value'); } { package Bar; use Moose; has 'foo' => ( reader => 'get_foo', writer => 'set_foo', initializer => sub { my ($self, $value, $callback, $attr) = @_; ::isa_ok($attr, 'Moose::Meta::Attribute'); ::is($attr->name, 'foo', '... got the right name'); $callback->($value * 2); }, ); __PACKAGE__->meta->make_immutable; } { my $bar = Bar->new(foo => 10); isa_ok($bar, 'Bar'); is($bar->get_foo, 20, 'initial value set to 2x given value'); } { package Fail::Bar; use Moose; has 'foo' => ( reader => 'get_foo', writer => 'set_foo', isa => 'Int', initializer => sub { my ($self, $value, $callback, $attr) = @_; ::isa_ok($attr, 'Moose::Meta::Attribute'); ::is($attr->name, 'foo', '... got the right name'); $callback->("Hello $value World"); }, ); __PACKAGE__->meta->make_immutable; } isnt( exception { Fail::Bar->new(foo => 10) }, undef, '... this fails, because initializer returns a bad type' ); done_testing; misc_attribute_coerce_lazy.t100644000767000024 160112200352345 22546 0ustar00etherstaff000000000000Moose-2.1005/t/attributes#!/usr/bin/perl use strict; use warnings; use Test::More; use Test::Fatal; { package HTTPHeader; use Moose; has 'array' => (is => 'ro'); has 'hash' => (is => 'ro'); } { package Request; use Moose; use Moose::Util::TypeConstraints; subtype Header => => as Object => where { $_->isa('HTTPHeader') }; coerce Header => from ArrayRef => via { HTTPHeader->new(array => $_[0]) } => from HashRef => via { HTTPHeader->new(hash => $_[0]) }; has 'headers' => ( is => 'rw', isa => 'Header', coerce => 1, lazy => 1, default => sub { [ 'content-type', 'text/html' ] } ); } my $r = Request->new; isa_ok($r, 'Request'); is( exception { $r->headers; }, undef, '... this coerces and passes the type constraint even with lazy' ); done_testing; wrapped_method_cxt_propagation.t100644000767000024 201112200352345 22506 0ustar00etherstaff000000000000Moose-2.1005/t/basics#!/usr/bin/perl use strict; use warnings; use Test::More; { package TouchyBase; use Moose; has x => ( is => 'rw', default => 0 ); sub inc { $_[0]->x( 1 + $_[0]->x ) } sub scalar_or_array { wantarray ? (qw/a b c/) : "x"; } sub void { die "this must be void context" if defined wantarray; } package AfterSub; use Moose; extends "TouchyBase"; after qw/scalar_or_array void/ => sub { my $self = shift; $self->inc; } } my $base = TouchyBase->new; my $after = AfterSub->new; foreach my $obj ( $base, $after ) { my $class = ref $obj; my @array = $obj->scalar_or_array; my $scalar = $obj->scalar_or_array; is_deeply(\@array, [qw/a b c/], "array context ($class)"); is($scalar, "x", "scalar context ($class)"); { local $@; eval { $obj->void }; ok( !$@, "void context ($class)" ); } if ( $obj->isa("AfterSub") ) { is( $obj->x, 3, "methods were wrapped" ); } } done_testing; DEMOLISH_fails_without_metaclass.t100644000767000024 174212200352345 22132 0ustar00etherstaff000000000000Moose-2.1005/t/bugsuse strict; use warnings; use Test::More; use Test::Fatal; { package MyClass; use Moose; sub DEMOLISH { } } my $object = MyClass->new; # Removing the metaclass simulates the case where the metaclass object # goes out of scope _before_ the object itself, which under normal # circumstances only happens during global destruction. Class::MOP::remove_metaclass_by_name('MyClass'); # The bug happened when DEMOLISHALL called # Class::MOP::class_of($object) and did not get a metaclass object # back. is( exception { $object->DESTROY }, undef, 'can call DESTROY on an object without a metaclass object in the CMOP cache' ); MyClass->meta->make_immutable; Class::MOP::remove_metaclass_by_name('MyClass'); # The bug didn't manifest for immutable objects, but this test should # help us prevent it happening in the future. is( exception { $object->DESTROY }, undef, 'can call DESTROY on an object without a metaclass object in the CMOP cache (immutable version)' ); done_testing; ClassEncapsulatedAttributes_test.t100644000767000024 513312200352345 22431 0ustar00etherstaff000000000000Moose-2.1005/t/cmopuse strict; use warnings; use Test::More; use File::Spec; use Class::MOP; BEGIN { require_ok(File::Spec->catfile('examples', 'ClassEncapsulatedAttributes.pod')); } { package Foo; use metaclass 'ClassEncapsulatedAttributes'; Foo->meta->add_attribute('foo' => ( accessor => 'foo', predicate => 'has_foo', default => 'init in FOO' )); Foo->meta->add_attribute('bar' => ( reader => 'get_bar', writer => 'set_bar', default => 'init in FOO' )); sub new { my $class = shift; $class->meta->new_object(@_); } package Bar; our @ISA = ('Foo'); Bar->meta->add_attribute('foo' => ( accessor => 'foo', predicate => 'has_foo', default => 'init in BAR' )); Bar->meta->add_attribute('bar' => ( reader => 'get_bar', writer => 'set_bar', default => 'init in BAR' )); sub SUPER_foo { (shift)->SUPER::foo(@_) } sub SUPER_has_foo { (shift)->SUPER::foo(@_) } sub SUPER_get_bar { (shift)->SUPER::get_bar() } sub SUPER_set_bar { (shift)->SUPER::set_bar(@_) } } { my $foo = Foo->new(); isa_ok($foo, 'Foo'); can_ok($foo, 'foo'); can_ok($foo, 'has_foo'); can_ok($foo, 'get_bar'); can_ok($foo, 'set_bar'); my $bar = Bar->new(); isa_ok($bar, 'Bar'); can_ok($bar, 'foo'); can_ok($bar, 'has_foo'); can_ok($bar, 'get_bar'); can_ok($bar, 'set_bar'); ok($foo->has_foo, '... Foo::has_foo == 1'); ok($bar->has_foo, '... Bar::has_foo == 1'); is($foo->foo, 'init in FOO', '... got the right default value for Foo::foo'); is($bar->foo, 'init in BAR', '... got the right default value for Bar::foo'); is($bar->SUPER_foo(), 'init in FOO', '... got the right default value for Bar::SUPER::foo'); $bar->SUPER_foo(undef); is($bar->SUPER_foo(), undef, '... successfully set Foo::foo through Bar::SUPER::foo'); ok(!$bar->SUPER_has_foo, '... BAR::SUPER::has_foo == 0'); ok($foo->has_foo, '... Foo::has_foo (is still) 1'); } { my $bar = Bar->new( 'Foo' => { 'foo' => 'Foo::foo' }, 'Bar' => { 'foo' => 'Bar::foo' } ); isa_ok($bar, 'Bar'); can_ok($bar, 'foo'); can_ok($bar, 'has_foo'); can_ok($bar, 'get_bar'); can_ok($bar, 'set_bar'); ok($bar->has_foo, '... Bar::has_foo == 1'); ok($bar->SUPER_has_foo, '... Bar::SUPER_has_foo == 1'); is($bar->foo, 'Bar::foo', '... got the right default value for Bar::foo'); is($bar->SUPER_foo(), 'Foo::foo', '... got the right default value for Bar::SUPER::foo'); } done_testing; immutable_constructor_error.t100644000767000024 157112200352345 22605 0ustar00etherstaff000000000000Moose-2.1005/t/immutable#!/usr/bin/perl use strict; use warnings; use Test::More; use Test::Fatal; =pod This tests to make sure that we provide the same error messages from an immutable constructor as is provided by a non-immutable constructor. =cut { package Foo; use Moose; has 'foo' => (is => 'rw', isa => 'Int'); Foo->meta->make_immutable(debug => 0); } my $scalar = 1; like( exception { Foo->new($scalar) }, qr/\QSingle parameters to new() must be a HASH ref/, 'Non-ref provided to immutable constructor gives useful error message' ); like( exception { Foo->new(\$scalar) }, qr/\QSingle parameters to new() must be a HASH ref/, 'Scalar ref provided to immutable constructor gives useful error message' ); like( exception { Foo->new(undef) }, qr/\QSingle parameters to new() must be a HASH ref/, 'undef provided to immutable constructor gives useful error message' ); done_testing; empty_method_modifiers_meta_bug.t100644000767000024 106712200352345 22517 0ustar00etherstaff000000000000Moose-2.1005/t/roles#!/usr/bin/perl use strict; use warnings; use Test::More; # test role and class package SomeRole; use Moose::Role; requires 'foo'; package SomeClass; use Moose; has 'foo' => (is => 'rw'); with 'SomeRole'; package main; #my $c = SomeClass->new; #isa_ok( $c, 'SomeClass'); for my $modifier_type (qw[ before around after ]) { my $get_func = "get_${modifier_type}_method_modifiers"; my @mms = eval{ SomeRole->meta->$get_func('foo') }; is($@, '', "$get_func for no method mods does not die"); is(scalar(@mms),0,'is an empty list'); } done_testing; method_exclusion_in_composition.t100644000767000024 533312200352345 22577 0ustar00etherstaff000000000000Moose-2.1005/t/roles#!/usr/bin/perl use strict; use warnings; use Test::More; use Test::Fatal; { package My::Role; use Moose::Role; sub foo { 'Foo::foo' } sub bar { 'Foo::bar' } sub baz { 'Foo::baz' } package My::Class; use Moose; with 'My::Role' => { -excludes => 'bar' }; } ok(My::Class->meta->has_method($_), "we have a $_ method") for qw(foo baz); ok(!My::Class->meta->has_method('bar'), '... but we excluded bar'); { package My::OtherRole; use Moose::Role; with 'My::Role' => { -excludes => 'foo' }; sub foo { 'My::OtherRole::foo' } sub bar { 'My::OtherRole::bar' } } ok(My::OtherRole->meta->has_method($_), "we have a $_ method") for qw(foo bar baz); ok(!My::OtherRole->meta->requires_method('foo'), '... and the &foo method is not required'); ok(!My::OtherRole->meta->requires_method('bar'), '... and the &bar method is not required'); { package Foo::Role; use Moose::Role; sub foo { 'Foo::Role::foo' } package Bar::Role; use Moose::Role; sub foo { 'Bar::Role::foo' } package Baz::Role; use Moose::Role; sub foo { 'Baz::Role::foo' } package My::Foo::Class; use Moose; ::is( ::exception { with 'Foo::Role' => { -excludes => 'foo' }, 'Bar::Role' => { -excludes => 'foo' }, 'Baz::Role'; }, undef, '... composed our roles correctly' ); package My::Foo::Class::Broken; use Moose; ::like( ::exception { with 'Foo::Role', 'Bar::Role' => { -excludes => 'foo' }, 'Baz::Role'; }, qr/Due to a method name conflict in roles 'Baz::Role' and 'Foo::Role', the method 'foo' must be implemented or excluded by 'My::Foo::Class::Broken'/, '... composed our roles correctly' ); } { my $foo = My::Foo::Class->new; isa_ok($foo, 'My::Foo::Class'); can_ok($foo, 'foo'); is($foo->foo, 'Baz::Role::foo', '... got the right method'); } { package My::Foo::Role; use Moose::Role; ::is( ::exception { with 'Foo::Role' => { -excludes => 'foo' }, 'Bar::Role' => { -excludes => 'foo' }, 'Baz::Role'; }, undef, '... composed our roles correctly' ); } ok(My::Foo::Role->meta->has_method('foo'), "we have a foo method"); ok(!My::Foo::Role->meta->requires_method('foo'), '... and the &foo method is not required'); { package My::Foo::Role::Other; use Moose::Role; ::is( ::exception { with 'Foo::Role', 'Bar::Role' => { -excludes => 'foo' }, 'Baz::Role'; }, undef, '... composed our roles correctly' ); } ok(!My::Foo::Role::Other->meta->has_method('foo'), "we dont have a foo method"); ok(My::Foo::Role::Other->meta->requires_method('foo'), '... and the &foo method is required'); done_testing; roles_and_req_method_edge_cases.t100644000767000024 1407412200352345 22456 0ustar00etherstaff000000000000Moose-2.1005/t/roles#!/usr/bin/perl use strict; use warnings; use Test::More; use Test::Fatal; =pod NOTE: A fair amount of these tests will likely be irrelevant once we have more fine grained control over the class building process. A lot of the edge cases tested here are actually related to class construction order and not any real functionality. - SL Role which requires a method implemented in another role as an override (it does not remove the requirement) =cut { package Role::RequireFoo; use strict; use warnings; use Moose::Role; requires 'foo'; package Role::ProvideFoo; use strict; use warnings; use Moose::Role; ::is( ::exception { with 'Role::RequireFoo'; }, undef, '... the required "foo" method will not exist yet (but we will live)' ); override 'foo' => sub { 'Role::ProvideFoo::foo' }; } is_deeply( [ Role::ProvideFoo->meta->get_required_method_list ], [ 'foo' ], '... foo method is still required for Role::ProvideFoo'); =pod Role which requires a method implemented in the consuming class as an override. It will fail since method modifiers are second class citizens. =cut { package Class::ProvideFoo::Base; use Moose; sub foo { 'Class::ProvideFoo::Base::foo' } package Class::ProvideFoo::Override1; use Moose; extends 'Class::ProvideFoo::Base'; ::is( ::exception { with 'Role::RequireFoo'; }, undef, '... the required "foo" method will be found in the superclass' ); override 'foo' => sub { 'Class::ProvideFoo::foo' }; package Class::ProvideFoo::Override2; use Moose; extends 'Class::ProvideFoo::Base'; override 'foo' => sub { 'Class::ProvideFoo::foo' }; ::is( ::exception { with 'Role::RequireFoo'; }, undef, '... the required "foo" method exists, although it is overriden locally' ); } =pod Now same thing, but with a before method modifier. =cut { package Class::ProvideFoo::Before1; use Moose; extends 'Class::ProvideFoo::Base'; ::is( ::exception { with 'Role::RequireFoo'; }, undef, '... the required "foo" method will be found in the superclass' ); before 'foo' => sub { 'Class::ProvideFoo::foo:before' }; package Class::ProvideFoo::Before2; use Moose; extends 'Class::ProvideFoo::Base'; before 'foo' => sub { 'Class::ProvideFoo::foo:before' }; ::is( ::exception { with 'Role::RequireFoo'; }, undef, '... the required "foo" method exists, although it is a before modifier locally' ); package Class::ProvideFoo::Before3; use Moose; extends 'Class::ProvideFoo::Base'; sub foo { 'Class::ProvideFoo::foo' } before 'foo' => sub { 'Class::ProvideFoo::foo:before' }; ::is( ::exception { with 'Role::RequireFoo'; }, undef, '... the required "foo" method exists locally, and it is modified locally' ); package Class::ProvideFoo::Before4; use Moose; extends 'Class::ProvideFoo::Base'; sub foo { 'Class::ProvideFoo::foo' } before 'foo' => sub { 'Class::ProvideFoo::foo:before' }; ::isa_ok(__PACKAGE__->meta->get_method('foo'), 'Class::MOP::Method::Wrapped'); ::is(__PACKAGE__->meta->get_method('foo')->get_original_method->package_name, __PACKAGE__, '... but the original method is from our package'); ::is( ::exception { with 'Role::RequireFoo'; }, undef, '... the required "foo" method exists in the symbol table (and we will live)' ); } =pod Now same thing, but with a method from an attribute method modifier. =cut { package Class::ProvideFoo::Attr1; use Moose; extends 'Class::ProvideFoo::Base'; ::is( ::exception { with 'Role::RequireFoo'; }, undef, '... the required "foo" method will be found in the superclass (but then overriden)' ); has 'foo' => (is => 'ro'); package Class::ProvideFoo::Attr2; use Moose; extends 'Class::ProvideFoo::Base'; has 'foo' => (is => 'ro'); ::is( ::exception { with 'Role::RequireFoo'; }, undef, '... the required "foo" method exists, and is an accessor' ); } # ... # a method required in a role, but then # implemented in the superclass (as an # attribute accessor too) { package Foo::Class::Base; use Moose; has 'bar' => ( isa => 'Int', is => 'rw', default => sub { 1 } ); } { package Foo::Role; use Moose::Role; requires 'bar'; has 'foo' => ( isa => 'Int', is => 'rw', lazy => 1, default => sub { (shift)->bar + 1 } ); } { package Foo::Class::Child; use Moose; extends 'Foo::Class::Base'; ::is( ::exception { with 'Foo::Role'; }, undef, '... our role combined successfully' ); } # a method required in a role and implemented in a superclass, with a method # modifier in the subclass. this should live, but dies in 0.26 -- hdp, # 2007-10-11 { package Bar::Class::Base; use Moose; sub bar { "hello!" } } { package Bar::Role; use Moose::Role; requires 'bar'; } { package Bar::Class::Child; use Moose; extends 'Bar::Class::Base'; after bar => sub { "o noes" }; # technically we could run lives_ok here, too, but putting it into a # grandchild class makes it more obvious why this matters. } { package Bar::Class::Grandchild; use Moose; extends 'Bar::Class::Child'; ::is( ::exception { with 'Bar::Role'; }, undef, 'required method exists in superclass as non-modifier, so we live' ); } { package Bar2::Class::Base; use Moose; sub bar { "hello!" } } { package Bar2::Role; use Moose::Role; requires 'bar'; } { package Bar2::Class::Child; use Moose; extends 'Bar2::Class::Base'; override bar => sub { "o noes" }; # technically we could run lives_ok here, too, but putting it into a # grandchild class makes it more obvious why this matters. } { package Bar2::Class::Grandchild; use Moose; extends 'Bar2::Class::Child'; ::is( ::exception { with 'Bar2::Role'; }, undef, 'required method exists in superclass as non-modifier, so we live' ); } done_testing; role_type_constraint.t100644000767000024 464112200352345 22650 0ustar00etherstaff000000000000Moose-2.1005/t/type_constraints#!/usr/bin/perl use strict; use warnings; use Test::More; use Test::Fatal; use Moose::Util::TypeConstraints; { package Gorch; use Moose::Role; package Bar; use Moose::Role; package Foo; use Moose::Role; with qw(Bar Gorch); package FooC; use Moose; with qw(Foo); package BarC; use Moose; with qw(Bar); } is( exception { role_type('Boop', message { "${_} is not a Boop" }) }, undef, 'role_type keywork works with message' ); my $type = find_type_constraint("Foo"); is( $type->role, "Foo", "role attribute" ); ok( $type->is_subtype_of("Gorch"), "subtype of gorch" ); ok( $type->is_subtype_of("Bar"), "subtype of bar" ); ok( $type->is_subtype_of("Object"), "subtype of Object" ); ok( !$type->is_subtype_of("ThisTypeDoesNotExist"), "not subtype of unknown type name" ); ok( !$type->is_a_type_of("ThisTypeDoesNotExist"), "not type of unknown type name" ); ok( find_type_constraint("Bar")->check(FooC->new), "Foo passes Bar" ); ok( find_type_constraint("Bar")->check(BarC->new), "Bar passes Bar" ); ok( !find_type_constraint("Gorch")->check(BarC->new), "but Bar doesn't pass Gorch"); my $boop = find_type_constraint("Boop"); ok( $boop->has_message, 'Boop has a message'); my $error = $boop->get_message(FooC->new); like( $error, qr/is not a Boop/, 'boop gives correct error message'); ok( $type->equals($type), "equals self" ); ok( $type->equals(Moose::Meta::TypeConstraint::Role->new( name => "__ANON__", role => "Foo" )), "equals anon constraint of same value" ); ok( $type->equals(Moose::Meta::TypeConstraint::Role->new( name => "Oink", role => "Foo" )), "equals differently named constraint of same value" ); ok( !$type->equals(Moose::Meta::TypeConstraint::Role->new( name => "__ANON__", role => "Bar" )), "doesn't equal other anon constraint" ); ok( $type->is_subtype_of(Moose::Meta::TypeConstraint::Role->new( name => "__ANON__", role => "Bar" )), "subtype of other anon constraint" ); { # See block comment in t/type_constraints/class_type_constraint.t my $type; is( exception { $type = role_type 'MyExampleRole' }, undef, 'Make initial role_type' ); is( exception { is(role_type('MyExampleRole'), $type, 're-running role_type gives same type') }, undef, 'No exception making duplicate role_type' );; is( exception { ok( ! $type->is_subtype_of('Bar'), 'MyExampleRole is not a subtype of Bar' ) }, undef, 'No exception for is_subtype_of undefined role' ); } done_testing; type_notation_parser.t100644000767000024 646312200352345 22656 0ustar00etherstaff000000000000Moose-2.1005/t/type_constraints#!/usr/bin/perl use strict; use warnings; use Test::More; use Moose::Util::TypeConstraints; =pod This is a good candidate for LectroTest Volunteers welcome :) =cut ## check the containers ok(Moose::Util::TypeConstraints::_detect_parameterized_type_constraint($_), '... this correctly detected a container (' . $_ . ')') for ( 'ArrayRef[Foo]', 'ArrayRef[Foo | Int]', 'ArrayRef[ArrayRef[Int]]', 'ArrayRef[ArrayRef[Int | Foo]]', 'ArrayRef[ArrayRef[Int|Str]]', ); ok(!Moose::Util::TypeConstraints::_detect_parameterized_type_constraint($_), '... this correctly detected a non-container (' . $_ . ')') for ( 'ArrayRef[]', 'ArrayRef[Foo]Bar', ); { my %split_tests = ( 'ArrayRef[Foo]' => [ 'ArrayRef', 'Foo' ], 'ArrayRef[Foo | Int]' => [ 'ArrayRef', 'Foo | Int' ], 'ArrayRef[Foo|Int]' => [ 'ArrayRef', 'Foo|Int' ], # these will get processed with recusion, # so we only need to detect it once 'ArrayRef[ArrayRef[Int]]' => [ 'ArrayRef', 'ArrayRef[Int]' ], 'ArrayRef[ArrayRef[Int | Foo]]' => [ 'ArrayRef', 'ArrayRef[Int | Foo]' ], 'ArrayRef[ArrayRef[Int|Str]]' => [ 'ArrayRef', 'ArrayRef[Int|Str]' ], ); is_deeply( [ Moose::Util::TypeConstraints::_parse_parameterized_type_constraint($_) ], $split_tests{$_}, '... this correctly split the container (' . $_ . ')' ) for keys %split_tests; } ## now for the unions ok(Moose::Util::TypeConstraints::_detect_type_constraint_union($_), '... this correctly detected union (' . $_ . ')') for ( 'Int | Str', 'Int|Str', 'ArrayRef[Foo] | Int', 'ArrayRef[Foo]|Int', 'Int | ArrayRef[Foo]', 'Int|ArrayRef[Foo]', 'ArrayRef[Foo | Int] | Str', 'ArrayRef[Foo|Int]|Str', 'Str | ArrayRef[Foo | Int]', 'Str|ArrayRef[Foo|Int]', 'Some|Silly|Name|With|Pipes | Int', 'Some|Silly|Name|With|Pipes|Int', ); ok(!Moose::Util::TypeConstraints::_detect_type_constraint_union($_), '... this correctly detected a non-union (' . $_ . ')') for ( 'Int', 'ArrayRef[Foo | Int]', 'ArrayRef[Foo|Int]', ); { my %split_tests = ( 'Int | Str' => [ 'Int', 'Str' ], 'Int|Str' => [ 'Int', 'Str' ], 'ArrayRef[Foo] | Int' => [ 'ArrayRef[Foo]', 'Int' ], 'ArrayRef[Foo]|Int' => [ 'ArrayRef[Foo]', 'Int' ], 'Int | ArrayRef[Foo]' => [ 'Int', 'ArrayRef[Foo]' ], 'Int|ArrayRef[Foo]' => [ 'Int', 'ArrayRef[Foo]' ], 'ArrayRef[Foo | Int] | Str' => [ 'ArrayRef[Foo | Int]', 'Str' ], 'ArrayRef[Foo|Int]|Str' => [ 'ArrayRef[Foo|Int]', 'Str' ], 'Str | ArrayRef[Foo | Int]' => [ 'Str', 'ArrayRef[Foo | Int]' ], 'Str|ArrayRef[Foo|Int]' => [ 'Str', 'ArrayRef[Foo|Int]' ], 'Some|Silly|Name|With|Pipes | Int' => [ 'Some', 'Silly', 'Name', 'With', 'Pipes', 'Int' ], 'Some|Silly|Name|With|Pipes|Int' => [ 'Some', 'Silly', 'Name', 'With', 'Pipes', 'Int' ], ); is_deeply( [ Moose::Util::TypeConstraints::_parse_type_constraint_union($_) ], $split_tests{$_}, '... this correctly split the union (' . $_ . ')' ) for keys %split_tests; } done_testing; extending_mooseish_moosesugar.t100644000767000024 172712200352345 22565 0ustar00etherstaff000000000000Moose-2.1005/t/recipes#!/usr/bin/perl -w use strict; use Test::More 'no_plan'; use Test::Fatal; $| = 1; # =begin testing SETUP { package MyApp::Mooseish; use Moose::Exporter; Moose::Exporter->setup_import_methods( with_meta => ['has_table'], class_metaroles => { class => ['MyApp::Meta::Class::Trait::HasTable'], }, ); sub has_table { my $meta = shift; $meta->table(shift); } package MyApp::Meta::Class::Trait::HasTable; use Moose::Role; has table => ( is => 'rw', isa => 'Str', ); } # =begin testing { { package MyApp::User; use Moose; MyApp::Mooseish->import; has_table( 'User' ); has( 'username' => ( is => 'ro' ) ); has( 'password' => ( is => 'ro' ) ); sub login { } } can_ok( MyApp::User->meta, 'table' ); is( MyApp::User->meta->table, 'User', 'MyApp::User->meta->table returns User' ); ok( MyApp::User->can('username'), 'MyApp::User has username method' ); } 1; Immutable000755000767000024 012200352345 20370 5ustar00etherstaff000000000000Moose-2.1005/benchmarks/cmop/lib/MOPPoint.pm100644000767000024 51212200352345 22135 0ustar00etherstaff000000000000Moose-2.1005/benchmarks/cmop/lib/MOP/Immutable package MOP::Immutable::Point; use strict; use warnings; use metaclass; __PACKAGE__->meta->add_attribute('x' => (accessor => 'x', default => 10)); __PACKAGE__->meta->add_attribute('y' => (accessor => 'y')); sub clear { my $self = shift; $self->x(0); $self->y(0); } __PACKAGE__->meta->make_immutable; 1; __END__ Installed000755000767000024 012200352345 20370 5ustar00etherstaff000000000000Moose-2.1005/benchmarks/cmop/lib/MOPPoint.pm100644000767000024 60312200352345 22136 0ustar00etherstaff000000000000Moose-2.1005/benchmarks/cmop/lib/MOP/Installed use lib reverse @INC; package MOP::Installed::Point; use strict; use warnings; use metaclass; __PACKAGE__->meta->add_attribute('x' => (accessor => 'x', default => 10)); __PACKAGE__->meta->add_attribute('y' => (accessor => 'y')); sub new { my $class = shift; $class->meta->new_object(@_); } sub clear { my $self = shift; $self->x(0); $self->y(0); } 1; __END__ ToClass.pm100644000767000024 1726112200352345 22154 0ustar00etherstaff000000000000Moose-2.1005/lib/Moose/Meta/Role/Applicationpackage Moose::Meta::Role::Application::ToClass; BEGIN { $Moose::Meta::Role::Application::ToClass::AUTHORITY = 'cpan:STEVAN'; } { $Moose::Meta::Role::Application::ToClass::VERSION = '2.1005'; } use strict; use warnings; use metaclass; use List::MoreUtils 'firstval'; use Moose::Util 'english_list'; use Scalar::Util 'weaken', 'blessed'; use base 'Moose::Meta::Role::Application'; __PACKAGE__->meta->add_attribute('role' => ( reader => 'role', Class::MOP::_definition_context(), )); __PACKAGE__->meta->add_attribute('class' => ( accessor => 'class', Class::MOP::_definition_context(), )); sub apply { my ($self, $role, $class) = @_; # We need weak_ref in CMOP :( weaken($self->{role} = $role); weaken($self->{class} = $class); $self->SUPER::apply($role, $class); $class->add_role($role); $class->add_role_application($self); } sub check_role_exclusions { my ($self, $role, $class) = @_; if ($class->excludes_role($role->name)) { $class->throw_error("Conflict detected: " . $class->name . " excludes role '" . $role->name . "'"); } foreach my $excluded_role_name ($role->get_excluded_roles_list) { if ($class->does_role($excluded_role_name)) { $class->throw_error("The class " . $class->name . " does the excluded role '$excluded_role_name'"); } } } sub check_required_methods { my ($self, $role, $class) = @_; my @missing; my @is_attr; # NOTE: # we might need to move this down below the # the attributes so that we can require any # attribute accessors. However I am thinking # that maybe those are somehow exempt from # the require methods stuff. foreach my $required_method ($role->get_required_method_list) { my $required_method_name = $required_method->name; if (!$class->find_method_by_name($required_method_name)) { next if $self->is_aliased_method($required_method_name); push @missing, $required_method; } } return unless @missing; my $error = ''; @missing = sort { $a->name cmp $b->name } @missing; my @conflicts = grep { $_->isa('Moose::Meta::Role::Method::Conflicting') } @missing; if (@conflicts) { my $conflict = $conflicts[0]; my $roles = $conflict->roles_as_english_list; my @same_role_conflicts = grep { $_->roles_as_english_list eq $roles } @conflicts; if (@same_role_conflicts == 1) { $error .= "Due to a method name conflict in roles " . $roles . ", the method '" . $conflict->name . "' must be implemented or excluded by '" . $class->name . q{'}; } else { my $methods = Moose::Util::english_list( map { q{'} . $_->name . q{'} } @same_role_conflicts ); $error .= "Due to method name conflicts in roles " . $roles . ", the methods " . $methods . " must be implemented or excluded by '" . $class->name . q{'}; } } elsif (@missing) { my $noun = @missing == 1 ? 'method' : 'methods'; my $list = Moose::Util::english_list( map { q{'} . $_ . q{'} } @missing ); $error .= q{'} . $role->name . "' requires the $noun $list " . "to be implemented by '" . $class->name . q{'}; if (my $meth = firstval { $class->name->can($_) } @missing) { $error .= ". If you imported functions intending to use them as " . "methods, you need to explicitly mark them as such, via " . $class->name . "->meta->add_method($meth => \\\&$meth)"; } } $class->throw_error($error); } sub check_required_attributes { } sub apply_attributes { my ($self, $role, $class) = @_; foreach my $attribute_name ($role->get_attribute_list) { # it if it has one already if ($class->has_attribute($attribute_name) && # make sure we haven't seen this one already too $class->get_attribute($attribute_name) != $role->get_attribute($attribute_name)) { next; } else { $class->add_attribute( $role->get_attribute($attribute_name)->attribute_for_class ); } } } sub apply_methods { my ( $self, $role, $class ) = @_; foreach my $method ( $role->_get_local_methods ) { my $method_name = $method->name; next if $method->isa('Class::MOP::Method::Meta'); unless ( $self->is_method_excluded($method_name) ) { my $class_method = $class->get_method($method_name); next if $class_method && $class_method->body != $method->body; $class->add_method( $method_name, $method, ); } next unless $self->is_method_aliased($method_name); my $aliased_method_name = $self->get_method_aliases->{$method_name}; my $class_method = $class->get_method($aliased_method_name); if ( $class_method && $class_method->body != $method->body ) { $class->throw_error( "Cannot create a method alias if a local method of the same name exists" ); } $class->add_method( $aliased_method_name, $method, ); } # we must reset the cache here since # we are just aliasing methods, otherwise # the modifiers go wonky. $class->reset_package_cache_flag; } sub apply_override_method_modifiers { my ($self, $role, $class) = @_; foreach my $method_name ($role->get_method_modifier_list('override')) { # it if it has one already then ... if ($class->has_method($method_name)) { next; } else { # if this is not a role, then we need to # find the original package of the method # so that we can tell the class were to # find the right super() method my $method = $role->get_override_method_modifier($method_name); my ($package) = Class::MOP::get_code_info($method); # if it is a class, we just add it $class->add_override_method_modifier($method_name, $method, $package); } } } sub apply_method_modifiers { my ($self, $modifier_type, $role, $class) = @_; my $add = "add_${modifier_type}_method_modifier"; my $get = "get_${modifier_type}_method_modifiers"; foreach my $method_name ($role->get_method_modifier_list($modifier_type)) { $class->$add( $method_name, $_ ) foreach $role->$get($method_name); } } 1; # ABSTRACT: Compose a role into a class __END__ =pod =head1 NAME Moose::Meta::Role::Application::ToClass - Compose a role into a class =head1 VERSION version 2.1005 =head1 DESCRIPTION =head2 METHODS =over 4 =item B =item B =item B =item B =item B =item B =item B =item B =item B =item B =back =head1 BUGS See L for details on reporting bugs. =head1 AUTHOR Moose is maintained by the Moose Cabal, along with the help of many contributors. See L and L for details. =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2013 by Infinity Interactive, Inc.. This is free software; you can redistribute it and/or modify it under the same terms as the Perl 5 programming language system itself. =cut TypeConstraints000755000767000024 012200352345 20113 5ustar00etherstaff000000000000Moose-2.1005/lib/Moose/UtilBuiltins.pm100644000767000024 2503412200352345 22426 0ustar00etherstaff000000000000Moose-2.1005/lib/Moose/Util/TypeConstraintspackage Moose::Util::TypeConstraints::Builtins; BEGIN { $Moose::Util::TypeConstraints::Builtins::AUTHORITY = 'cpan:STEVAN'; } { $Moose::Util::TypeConstraints::Builtins::VERSION = '2.1005'; } use strict; use warnings; use Class::Load qw( is_class_loaded ); use List::MoreUtils (); use Scalar::Util qw( blessed looks_like_number reftype ); sub type { goto &Moose::Util::TypeConstraints::type } sub subtype { goto &Moose::Util::TypeConstraints::subtype } sub as { goto &Moose::Util::TypeConstraints::as } sub where (&) { goto &Moose::Util::TypeConstraints::where } sub optimize_as (&) { goto &Moose::Util::TypeConstraints::optimize_as } sub inline_as (&) { goto &Moose::Util::TypeConstraints::inline_as } sub define_builtins { my $registry = shift; type 'Any' # meta-type including all => where {1} => inline_as { '1' }; subtype 'Item' # base type => as 'Any' => inline_as { '1' }; subtype 'Undef' => as 'Item' => where { !defined($_) } => inline_as { '!defined(' . $_[1] . ')' }; subtype 'Defined' => as 'Item' => where { defined($_) } => inline_as { 'defined(' . $_[1] . ')' }; subtype 'Bool' => as 'Item' => where { !defined($_) || $_ eq "" || "$_" eq '1' || "$_" eq '0' } => inline_as { '(' . '!defined(' . $_[1] . ') ' . '|| ' . $_[1] . ' eq "" ' . '|| (' . $_[1] . '."") eq "1" ' . '|| (' . $_[1] . '."") eq "0"' . ')' }; subtype 'Value' => as 'Defined' => where { !ref($_) } => inline_as { $_[0]->parent()->_inline_check($_[1]) . ' && !ref(' . $_[1] . ')' }; subtype 'Ref' => as 'Defined' => where { ref($_) } # no need to call parent - ref also checks for definedness => inline_as { 'ref(' . $_[1] . ')' }; subtype 'Str' => as 'Value' => where { ref(\$_) eq 'SCALAR' || ref(\(my $val = $_)) eq 'SCALAR' } => inline_as { $_[0]->parent()->_inline_check($_[1]) . ' && (' . 'ref(\\' . $_[1] . ') eq "SCALAR"' . ' || ref(\\(my $val = ' . $_[1] . ')) eq "SCALAR"' . ')' }; my $value_type = Moose::Util::TypeConstraints::find_type_constraint('Value'); subtype 'Num' => as 'Str' => where { my $val = $_; ($val =~ /\A[+-]?[0-9]+\z/) || ( $val =~ /\A(?:[+-]?) #matches optional +- in the beginning (?=[0-9]|\.[0-9]) #matches previous +- only if there is something like 3 or .3 [0-9]* #matches 0-9 zero or more times (?:\.[0-9]+)? #matches optional .89 or nothing (?:[Ee](?:[+-]?[0-9]+))? #matches E1 or e1 or e-1 or e+1 etc \z/x ); } => inline_as { # the long Str tests are redundant here #storing $_[1] in a temporary value, #so that $_[1] won't get converted to a string for regex match #see t/attributes/numeric_defaults.t for more details 'my $val = '.$_[1].';'. $value_type->_inline_check('$val') .' && ( $val =~ /\A[+-]?[0-9]+\z/ || ' . '$val =~ /\A(?:[+-]?) #matches optional +- in the beginning (?=[0-9]|\.[0-9]) #matches previous +- only if there is something like 3 or .3 [0-9]* #matches 0-9 zero or more times (?:\.[0-9]+)? #matches optional .89 or nothing (?:[Ee](?:[+-]?[0-9]+))? #matches E1 or e1 or e-1 or e+1 etc \z/x ); ' }; subtype 'Int' => as 'Num' => where { (my $val = $_) =~ /\A-?[0-9]+\z/ } => inline_as { $value_type->_inline_check($_[1]) . ' && (my $val = ' . $_[1] . ') =~ /\A-?[0-9]+\z/' }; subtype 'CodeRef' => as 'Ref' => where { ref($_) eq 'CODE' } => inline_as { 'ref(' . $_[1] . ') eq "CODE"' }; subtype 'RegexpRef' => as 'Ref' => where( \&_RegexpRef ) => inline_as { 'Moose::Util::TypeConstraints::Builtins::_RegexpRef(' . $_[1] . ')' }; subtype 'GlobRef' => as 'Ref' => where { ref($_) eq 'GLOB' } => inline_as { 'ref(' . $_[1] . ') eq "GLOB"' }; # NOTE: scalar filehandles are GLOB refs, but a GLOB ref is not always a # filehandle subtype 'FileHandle' => as 'Ref' => where { (ref($_) eq "GLOB" && Scalar::Util::openhandle($_)) || (blessed($_) && $_->isa("IO::Handle")); } => inline_as { '(ref(' . $_[1] . ') eq "GLOB" ' . '&& Scalar::Util::openhandle(' . $_[1] . ')) ' . '|| (Scalar::Util::blessed(' . $_[1] . ') ' . '&& ' . $_[1] . '->isa("IO::Handle"))' }; subtype 'Object' => as 'Ref' => where { blessed($_) } => inline_as { 'Scalar::Util::blessed(' . $_[1] . ')' }; subtype 'ClassName' => as 'Str' => where { is_class_loaded($_) } # the long Str tests are redundant here => inline_as { 'Class::Load::is_class_loaded(' . $_[1] . ')' }; subtype 'RoleName' => as 'ClassName' => where { (Class::MOP::class_of($_) || return)->isa('Moose::Meta::Role'); } => inline_as { $_[0]->parent()->_inline_check($_[1]) . ' && do {' . 'my $meta = Class::MOP::class_of(' . $_[1] . ');' . '$meta && $meta->isa("Moose::Meta::Role");' . '}' }; $registry->add_type_constraint( Moose::Meta::TypeConstraint::Parameterizable->new( name => 'ScalarRef', package_defined_in => __PACKAGE__, parent => Moose::Util::TypeConstraints::find_type_constraint('Ref'), constraint => sub { ref($_) eq 'SCALAR' || ref($_) eq 'REF' }, constraint_generator => sub { my $type_parameter = shift; my $check = $type_parameter->_compiled_type_constraint; return sub { return $check->( ${$_} ); }; }, inlined => sub { 'ref(' . $_[1] . ') eq "SCALAR" ' . '|| ref(' . $_[1] . ') eq "REF"' }, inline_generator => sub { my $self = shift; my $type_parameter = shift; my $val = shift; '(ref(' . $val . ') eq "SCALAR" || ref(' . $val . ') eq "REF") ' . '&& ' . $type_parameter->_inline_check('${(' . $val . ')}') }, ) ); $registry->add_type_constraint( Moose::Meta::TypeConstraint::Parameterizable->new( name => 'ArrayRef', package_defined_in => __PACKAGE__, parent => Moose::Util::TypeConstraints::find_type_constraint('Ref'), constraint => sub { ref($_) eq 'ARRAY' }, constraint_generator => sub { my $type_parameter = shift; my $check = $type_parameter->_compiled_type_constraint; return sub { foreach my $x (@$_) { ( $check->($x) ) || return; } 1; } }, inlined => sub { 'ref(' . $_[1] . ') eq "ARRAY"' }, inline_generator => sub { my $self = shift; my $type_parameter = shift; my $val = shift; 'do {' . 'my $check = ' . $val . ';' . 'ref($check) eq "ARRAY" ' . '&& &List::MoreUtils::all(' . 'sub { ' . $type_parameter->_inline_check('$_') . ' }, ' . '@{$check}' . ')' . '}'; }, ) ); $registry->add_type_constraint( Moose::Meta::TypeConstraint::Parameterizable->new( name => 'HashRef', package_defined_in => __PACKAGE__, parent => Moose::Util::TypeConstraints::find_type_constraint('Ref'), constraint => sub { ref($_) eq 'HASH' }, constraint_generator => sub { my $type_parameter = shift; my $check = $type_parameter->_compiled_type_constraint; return sub { foreach my $x ( values %$_ ) { ( $check->($x) ) || return; } 1; } }, inlined => sub { 'ref(' . $_[1] . ') eq "HASH"' }, inline_generator => sub { my $self = shift; my $type_parameter = shift; my $val = shift; 'do {' . 'my $check = ' . $val . ';' . 'ref($check) eq "HASH" ' . '&& &List::MoreUtils::all(' . 'sub { ' . $type_parameter->_inline_check('$_') . ' }, ' . 'values %{$check}' . ')' . '}'; }, ) ); $registry->add_type_constraint( Moose::Meta::TypeConstraint::Parameterizable->new( name => 'Maybe', package_defined_in => __PACKAGE__, parent => Moose::Util::TypeConstraints::find_type_constraint('Item'), constraint => sub {1}, constraint_generator => sub { my $type_parameter = shift; my $check = $type_parameter->_compiled_type_constraint; return sub { return 1 if not( defined($_) ) || $check->($_); return; } }, inlined => sub {'1'}, inline_generator => sub { my $self = shift; my $type_parameter = shift; my $val = shift; '!defined(' . $val . ') ' . '|| (' . $type_parameter->_inline_check($val) . ')' }, ) ); } 1; __END__ =pod =for pod_coverage_needs_some_pod =cut attribute_reader_generation.t100644000767000024 475312200352345 22724 0ustar00etherstaff000000000000Moose-2.1005/t/attributes#!/usr/bin/perl use strict; use warnings; use Test::More; use Test::Fatal; { package Foo; use Moose; eval { has 'foo' => ( reader => 'get_foo' ); }; ::ok(!$@, '... created the reader method okay'); eval { has 'lazy_foo' => ( reader => 'get_lazy_foo', lazy => 1, default => sub { 10 } ); }; ::ok(!$@, '... created the lazy reader method okay') or warn $@; eval { has 'lazy_weak_foo' => ( reader => 'get_lazy_weak_foo', lazy => 1, default => sub { our $AREF = [] }, weak_ref => 1, ); }; ::ok(!$@, '... created the lazy weak reader method okay') or warn $@; my $warn; eval { local $SIG{__WARN__} = sub { $warn = $_[0] }; has 'mtfnpy' => ( reder => 'get_mftnpy' ); }; ::ok($warn, '... got a warning for mispelled attribute argument'); } { my $foo = Foo->new; isa_ok($foo, 'Foo'); can_ok($foo, 'get_foo'); is($foo->get_foo(), undef, '... got an undefined value'); isnt( exception { $foo->get_foo(100); }, undef, '... get_foo is a read-only' ); ok(!exists($foo->{lazy_foo}), '... no value in get_lazy_foo slot'); can_ok($foo, 'get_lazy_foo'); is($foo->get_lazy_foo(), 10, '... got an deferred value'); isnt( exception { $foo->get_lazy_foo(100); }, undef, '... get_lazy_foo is a read-only' ); is($foo->get_lazy_weak_foo(), $Foo::AREF, 'got the right value'); ok($foo->meta->get_meta_instance->slot_value_is_weak($foo, 'lazy_weak_foo'), '... and it is weak'); } { my $foo = Foo->new; isa_ok($foo, 'Foo'); my $attr = $foo->meta->find_attribute_by_name("lazy_foo"); isa_ok( $attr, "Moose::Meta::Attribute" ); ok( $attr->is_lazy, "it's lazy" ); is( $attr->get_raw_value($foo), undef, "raw value" ); is( $attr->get_value($foo), 10, "lazy value" ); is( $attr->get_raw_value($foo), 10, "raw value" ); my $lazy_weak_attr = $foo->meta->find_attribute_by_name("lazy_weak_foo"); is( $lazy_weak_attr->get_value($foo), $Foo::AREF, "it's the right value" ); ok( $foo->meta->get_meta_instance->slot_value_is_weak($foo, 'lazy_weak_foo'), "and it is weak"); } { my $foo = Foo->new(foo => 10, lazy_foo => 100); isa_ok($foo, 'Foo'); is($foo->get_foo(), 10, '... got the correct value'); is($foo->get_lazy_foo(), 100, '... got the correct value'); } done_testing; attribute_traits_registered.t100644000767000024 571312200352345 22767 0ustar00etherstaff000000000000Moose-2.1005/t/attributes#!/usr/bin/perl use strict; use warnings; use Test::More; use Test::Moose; { package My::Attribute::Trait; use Moose::Role; has 'alias_to' => (is => 'ro', isa => 'Str'); has foo => ( is => "ro", default => "blah" ); after 'install_accessors' => sub { my $self = shift; $self->associated_class->add_method( $self->alias_to, $self->get_read_method_ref ); }; package Moose::Meta::Attribute::Custom::Trait::Aliased; sub register_implementation { 'My::Attribute::Trait' } } { package My::Other::Attribute::Trait; use Moose::Role; my $method = sub { 42; }; has the_other_attr => ( isa => "Str", is => "rw", default => "oink" ); after 'install_accessors' => sub { my $self = shift; $self->associated_class->add_method( 'additional_method', $method ); }; package Moose::Meta::Attribute::Custom::Trait::Other; sub register_implementation { 'My::Other::Attribute::Trait' } } { package My::Class; use Moose; has 'bar' => ( traits => [qw/Aliased/], is => 'ro', isa => 'Int', alias_to => 'baz', ); } { package My::Derived::Class; use Moose; extends 'My::Class'; has '+bar' => ( traits => [qw/Other/], ); } my $c = My::Class->new(bar => 100); isa_ok($c, 'My::Class'); is($c->bar, 100, '... got the right value for bar'); can_ok($c, 'baz') and is($c->baz, 100, '... got the right value for baz'); my $bar_attr = $c->meta->get_attribute('bar'); does_ok($bar_attr, 'My::Attribute::Trait'); is($bar_attr->foo, "blah", "attr initialized"); ok(!$bar_attr->meta->does_role('Aliased'), "does_role ignores aliases for sanity"); ok($bar_attr->does('Aliased'), "attr->does uses aliases"); ok(!$bar_attr->meta->does_role('Fictional'), "does_role returns false for nonexistent roles"); ok(!$bar_attr->does('Fictional'), "attr->does returns false for nonexistent roles"); my $quux = My::Derived::Class->new(bar => 1000); is($quux->bar, 1000, '... got the right value for bar'); can_ok($quux, 'baz'); is($quux->baz, 1000, '... got the right value for baz'); my $derived_bar_attr = $quux->meta->get_attribute("bar"); does_ok($derived_bar_attr, 'My::Attribute::Trait' ); is( $derived_bar_attr->foo, "blah", "attr initialized" ); does_ok($derived_bar_attr, 'My::Other::Attribute::Trait' ); is($derived_bar_attr->the_other_attr, "oink", "attr initialized" ); ok(!$derived_bar_attr->meta->does_role('Aliased'), "does_role ignores aliases for sanity"); ok($derived_bar_attr->does('Aliased'), "attr->does uses aliases"); ok(!$derived_bar_attr->meta->does_role('Fictional'), "does_role returns false for nonexistent roles"); ok(!$derived_bar_attr->does('Fictional'), "attr->does returns false for nonexistent roles"); can_ok($quux, 'additional_method'); is(eval { $quux->additional_method }, 42, '... got the right value for additional_method'); done_testing; attribute_writer_generation.t100644000767000024 576712200352345 23004 0ustar00etherstaff000000000000Moose-2.1005/t/attributes#!/usr/bin/perl use strict; use warnings; use Test::More; use Test::Fatal; use Scalar::Util 'isweak'; { package Foo; use Moose; eval { has 'foo' => ( reader => 'get_foo', writer => 'set_foo', ); }; ::ok(!$@, '... created the writer method okay'); eval { has 'foo_required' => ( reader => 'get_foo_required', writer => 'set_foo_required', required => 1, ); }; ::ok(!$@, '... created the required writer method okay'); eval { has 'foo_int' => ( reader => 'get_foo_int', writer => 'set_foo_int', isa => 'Int', ); }; ::ok(!$@, '... created the writer method with type constraint okay'); eval { has 'foo_weak' => ( reader => 'get_foo_weak', writer => 'set_foo_weak', weak_ref => 1 ); }; ::ok(!$@, '... created the writer method with weak_ref okay'); } { my $foo = Foo->new(foo_required => 'required'); isa_ok($foo, 'Foo'); # regular writer can_ok($foo, 'set_foo'); is($foo->get_foo(), undef, '... got an unset value'); is( exception { $foo->set_foo(100); }, undef, '... set_foo wrote successfully' ); is($foo->get_foo(), 100, '... got the correct set value'); ok(!isweak($foo->{foo}), '... it is not a weak reference'); # required writer isnt( exception { Foo->new; }, undef, '... cannot create without the required attribute' ); can_ok($foo, 'set_foo_required'); is($foo->get_foo_required(), 'required', '... got an unset value'); is( exception { $foo->set_foo_required(100); }, undef, '... set_foo_required wrote successfully' ); is($foo->get_foo_required(), 100, '... got the correct set value'); isnt( exception { $foo->set_foo_required(); }, undef, '... set_foo_required died successfully with no value' ); is( exception { $foo->set_foo_required(undef); }, undef, '... set_foo_required did accept undef' ); ok(!isweak($foo->{foo_required}), '... it is not a weak reference'); # with type constraint can_ok($foo, 'set_foo_int'); is($foo->get_foo_int(), undef, '... got an unset value'); is( exception { $foo->set_foo_int(100); }, undef, '... set_foo_int wrote successfully' ); is($foo->get_foo_int(), 100, '... got the correct set value'); isnt( exception { $foo->set_foo_int("Foo"); }, undef, '... set_foo_int died successfully' ); ok(!isweak($foo->{foo_int}), '... it is not a weak reference'); # with weak_ref my $test = []; can_ok($foo, 'set_foo_weak'); is($foo->get_foo_weak(), undef, '... got an unset value'); is( exception { $foo->set_foo_weak($test); }, undef, '... set_foo_weak wrote successfully' ); is($foo->get_foo_weak(), $test, '... got the correct set value'); ok(isweak($foo->{foo_weak}), '... it is a weak reference'); } done_testing; moose_respects_type_constraints.t100644000767000024 241012200352345 22750 0ustar00etherstaff000000000000Moose-2.1005/t/basics#!/usr/bin/perl use strict; use warnings; use Test::More; use Test::Fatal; use Moose::Util::TypeConstraints; =pod This tests demonstrates that Moose will not override a preexisting type constraint of the same name when making constraints for a Moose-class. It also tests that an attribute which uses a 'Foo' for its isa option will get the subtype Foo, and not a type representing the Foo moose class. =cut BEGIN { # create this subtype first (in BEGIN) subtype Foo => as 'Value' => where { $_ eq 'Foo' }; } { # now seee if Moose will override it package Foo; use Moose; } my $foo_constraint = find_type_constraint('Foo'); isa_ok($foo_constraint, 'Moose::Meta::TypeConstraint'); is($foo_constraint->parent->name, 'Value', '... got the Value subtype for Foo'); ok($foo_constraint->check('Foo'), '... my constraint passed correctly'); ok(!$foo_constraint->check('Bar'), '... my constraint failed correctly'); { package Bar; use Moose; has 'foo' => (is => 'rw', isa => 'Foo'); } my $bar = Bar->new; isa_ok($bar, 'Bar'); is( exception { $bar->foo('Foo'); }, undef, '... checked the type constraint correctly' ); isnt( exception { $bar->foo(Foo->new); }, undef, '... checked the type constraint correctly' ); done_testing; inlined_constructors_n_types.t100644000767000024 353012200352345 22760 0ustar00etherstaff000000000000Moose-2.1005/t/immutable#!/usr/bin/perl use strict; use warnings; use Test::More; use Test::Fatal; =pod This tests to make sure that the inlined constructor has all the type constraints in order, even in the cases when there is no type constraint available, such as with a Class::MOP::Attribute object. =cut { package Foo; use Moose; use Moose::Util::TypeConstraints; coerce 'Int' => from 'Str' => via { length $_ ? $_ : 69 }; has 'foo' => (is => 'rw', isa => 'Int'); has 'baz' => (is => 'rw', isa => 'Int'); has 'zot' => (is => 'rw', isa => 'Int', init_arg => undef); has 'moo' => (is => 'rw', isa => 'Int', coerce => 1, default => '', required => 1); has 'boo' => (is => 'rw', isa => 'Int', coerce => 1, builder => '_build_boo', required => 1); sub _build_boo { '' } Foo->meta->add_attribute( Class::MOP::Attribute->new( 'bar' => ( accessor => 'bar', ) ) ); } for (1..2) { my $is_immutable = Foo->meta->is_immutable; my $mutable_string = $is_immutable ? 'immutable' : 'mutable'; is( exception { my $f = Foo->new(foo => 10, bar => "Hello World", baz => 10, zot => 4); is($f->moo, 69, "Type coercion works as expected on default ($mutable_string)"); is($f->boo, 69, "Type coercion works as expected on builder ($mutable_string)"); }, undef, "... this passes the constuctor correctly ($mutable_string)" ); is( exception { Foo->new(foo => 10, bar => "Hello World", baz => 10, zot => "not an int"); }, undef, "... the constructor doesn't care about 'zot' ($mutable_string)" ); isnt( exception { Foo->new(foo => "Hello World", bar => 100, baz => "Hello World"); }, undef, "... this fails the constuctor correctly ($mutable_string)" ); Foo->meta->make_immutable(debug => 0) unless $is_immutable; } done_testing; test_moose_has_attribute_ok.t100644000767000024 153312200352345 22740 0ustar00etherstaff000000000000Moose-2.1005/t/test_moose#!/usr/bin/perl use strict; use warnings; use Test::Builder::Tester; use Test::More; use Test::Moose; { package Foo; use Moose; has 'foo', is => 'bare'; } { package Bar; use Moose; extends 'Foo'; has 'bar', is => 'bare'; } test_out('ok 1 - ... has_attribute_ok(Foo, foo) passes'); has_attribute_ok('Foo', 'foo', '... has_attribute_ok(Foo, foo) passes'); test_out ('not ok 2 - ... has_attribute_ok(Foo, bar) fails'); test_fail (+2); has_attribute_ok('Foo', 'bar', '... has_attribute_ok(Foo, bar) fails'); test_out('ok 3 - ... has_attribute_ok(Bar, foo) passes'); has_attribute_ok('Bar', 'foo', '... has_attribute_ok(Bar, foo) passes'); test_out('ok 4 - ... has_attribute_ok(Bar, bar) passes'); has_attribute_ok('Bar', 'bar', '... has_attribute_ok(Bar, bar) passes'); test_test ('has_attribute_ok'); done_testing; class_type_constraint.t100644000767000024 756312200352345 23022 0ustar00etherstaff000000000000Moose-2.1005/t/type_constraints#!/usr/bin/perl use strict; use warnings; use Test::More; use Test::Fatal; use Moose::Util::TypeConstraints; { package Gorch; use Moose; package Bar; use Moose; package Foo; use Moose; extends qw(Bar Gorch); } is( exception { class_type 'Beep' }, undef, 'class_type keywork works' ); is( exception { class_type('Boop', message { "${_} is not a Boop" }) }, undef, 'class_type keywork works with message' ); my $type = find_type_constraint("Foo"); is( $type->class, "Foo", "class attribute" ); ok( !$type->is_subtype_of('Foo'), "Foo is not subtype of Foo" ); ok( !$type->is_subtype_of($type), '$foo_type is not subtype of $foo_type' ); ok( $type->is_subtype_of("Gorch"), "subtype of gorch" ); ok( $type->is_subtype_of("Bar"), "subtype of bar" ); ok( $type->is_subtype_of("Object"), "subtype of Object" ); ok( !$type->is_subtype_of("ThisTypeDoesNotExist"), "not subtype of undefined type" ); ok( !$type->is_a_type_of("ThisTypeDoesNotExist"), "not type of undefined type" ); ok( find_type_constraint("Bar")->check(Foo->new), "Foo passes Bar" ); ok( find_type_constraint("Bar")->check(Bar->new), "Bar passes Bar" ); ok( !find_type_constraint("Gorch")->check(Bar->new), "but Bar doesn't pass Gorch"); ok( find_type_constraint("Beep")->check( bless {} => 'Beep' ), "Beep passes Beep" ); my $boop = find_type_constraint("Boop"); ok( $boop->has_message, 'Boop has a message'); my $error = $boop->get_message(Foo->new); like( $error, qr/is not a Boop/, 'boop gives correct error message'); ok( $type->equals($type), "equals self" ); ok( $type->equals(Moose::Meta::TypeConstraint::Class->new( name => "__ANON__", class => "Foo" )), "equals anon constraint of same value" ); ok( $type->equals(Moose::Meta::TypeConstraint::Class->new( name => "Oink", class => "Foo" )), "equals differently named constraint of same value" ); ok( !$type->equals(Moose::Meta::TypeConstraint::Class->new( name => "__ANON__", class => "Bar" )), "doesn't equal other anon constraint" ); ok( $type->is_subtype_of(Moose::Meta::TypeConstraint::Class->new( name => "__ANON__", class => "Bar" )), "subtype of other anon constraint" ); { package Parent; sub parent { } } { package Child; use base 'Parent'; } { my $parent = Moose::Meta::TypeConstraint::Class->new( name => 'Parent', class => 'Parent', ); ok($parent->is_a_type_of('Parent')); ok(!$parent->is_subtype_of('Parent')); ok($parent->is_a_type_of($parent)); ok(!$parent->is_subtype_of($parent)); my $child = Moose::Meta::TypeConstraint::Class->new( name => 'Child', class => 'Child', ); ok($child->is_a_type_of('Child')); ok(!$child->is_subtype_of('Child')); ok($child->is_a_type_of($child)); ok(!$child->is_subtype_of($child)); ok($child->is_a_type_of('Parent')); ok($child->is_subtype_of('Parent')); ok($child->is_a_type_of($parent)); ok($child->is_subtype_of($parent)); } { my $type; is( exception { $type = class_type 'MyExampleClass' }, undef, 'Make initial class_type' ); coerce 'MyExampleClass', from 'Str', via { bless {}, 'MyExampleClass' }; # We test class_type keeping the existing type (not making a new one) here. is( exception { is(class_type('MyExampleClass'), $type, 're-running class_type gives same type') }, undef, 'No exception making duplicate class_type' );; # Next define a class which needs this type and it's original coercion # Note this has to be after the 2nd class_type call to test the bug as M::M::Attribute grabs # the type constraint which is there at the time the attribute decleration runs. { package HoldsExample; use Moose; has foo => ( isa => 'MyExampleClass', is => 'ro', coerce => 1, required => 1 ); no Moose; } is( exception { isa_ok(HoldsExample->new(foo => "bar")->foo, 'MyExampleClass') }, undef, 'class_type coercion works' ); } done_testing; maybe_type_constraint.t100644000767000024 744112200352345 23005 0ustar00etherstaff000000000000Moose-2.1005/t/type_constraints#!/usr/bin/perl use strict; use warnings; use Test::More; use Test::Fatal; use Moose::Util::TypeConstraints; my $type = Moose::Util::TypeConstraints::find_or_parse_type_constraint('Maybe[Int]'); isa_ok($type, 'Moose::Meta::TypeConstraint'); isa_ok($type, 'Moose::Meta::TypeConstraint::Parameterized'); ok( $type->equals($type), "equals self" ); ok( !$type->equals($type->parent), "not equal to parent" ); ok( !$type->equals(find_type_constraint("Maybe")), "not equal to Maybe" ); ok( $type->parent->equals(find_type_constraint("Maybe")), "parent is Maybe" ); ok( $type->equals( Moose::Meta::TypeConstraint::Parameterized->new( name => "__ANON__", parent => find_type_constraint("Maybe"), type_parameter => find_type_constraint("Int") ) ), "equal to clone" ); ok( !$type->equals( Moose::Meta::TypeConstraint::Parameterized->new( name => "__ANON__", parent => find_type_constraint("Maybe"), type_parameter => find_type_constraint("Str") ) ), "not equal to clone with diff param" ); ok( !$type->equals( Moose::Util::TypeConstraints::find_or_parse_type_constraint('Maybe[Str]') ), "not equal to declarative version of diff param" ); ok($type->check(10), '... checked type correctly (pass)'); ok($type->check(undef), '... checked type correctly (pass)'); ok(!$type->check('Hello World'), '... checked type correctly (fail)'); ok(!$type->check([]), '... checked type correctly (fail)'); { package Bar; use Moose; package Foo; use Moose; use Moose::Util::TypeConstraints; has 'arr' => (is => 'rw', isa => 'Maybe[ArrayRef]', required => 1); has 'bar' => (is => 'rw', isa => class_type('Bar')); has 'maybe_bar' => (is => 'rw', isa => maybe_type(class_type('Bar'))); } is( exception { Foo->new(arr => [], bar => Bar->new); }, undef, '... Bar->new isa Bar' ); isnt( exception { Foo->new(arr => [], bar => undef); }, undef, '... undef isnta Bar' ); is( exception { Foo->new(arr => [], maybe_bar => Bar->new); }, undef, '... Bar->new isa maybe(Bar)' ); is( exception { Foo->new(arr => [], maybe_bar => undef); }, undef, '... undef isa maybe(Bar)' ); isnt( exception { Foo->new(arr => [], maybe_bar => 1); }, undef, '... 1 isnta maybe(Bar)' ); is( exception { Foo->new(arr => []); }, undef, '... it worked!' ); is( exception { Foo->new(arr => undef); }, undef, '... it worked!' ); isnt( exception { Foo->new(arr => 100); }, undef, '... failed the type check' ); isnt( exception { Foo->new(arr => 'hello world'); }, undef, '... failed the type check' ); { package Test::MooseX::Types::Maybe; use Moose; has 'Maybe_Int' => (is=>'rw', isa=>'Maybe[Int]'); has 'Maybe_ArrayRef' => (is=>'rw', isa=>'Maybe[ArrayRef]'); has 'Maybe_HashRef' => (is=>'rw', isa=>'Maybe[HashRef]'); has 'Maybe_ArrayRefInt' => (is=>'rw', isa=>'Maybe[ArrayRef[Int]]'); has 'Maybe_HashRefInt' => (is=>'rw', isa=>'Maybe[HashRef[Int]]'); } ok my $obj = Test::MooseX::Types::Maybe->new => 'Create good test object'; ## Maybe[Int] ok my $Maybe_Int = Moose::Util::TypeConstraints::find_or_parse_type_constraint('Maybe[Int]') => 'made TC Maybe[Int]'; ok $Maybe_Int->check(1) => 'passed (1)'; ok $obj->Maybe_Int(1) => 'assigned (1)'; ok $Maybe_Int->check() => 'passed ()'; ok $obj->Maybe_Int() => 'assigned ()'; ok $Maybe_Int->check(0) => 'passed (0)'; ok defined $obj->Maybe_Int(0) => 'assigned (0)'; ok $Maybe_Int->check(undef) => 'passed (undef)'; ok sub {$obj->Maybe_Int(undef); 1}->() => 'assigned (undef)'; ok !$Maybe_Int->check("") => 'failed ("")'; like( exception { $obj->Maybe_Int("") }, qr/Attribute \(Maybe_Int\) does not pass the type constraint/, 'failed assigned ("")' ); ok !$Maybe_Int->check("a") => 'failed ("a")'; like( exception { $obj->Maybe_Int("a") }, qr/Attribute \(Maybe_Int\) does not pass the type constraint/, 'failed assigned ("a")' ); done_testing; subtyping_union_types.t100644000767000024 555212200352345 23064 0ustar00etherstaff000000000000Moose-2.1005/t/type_constraints#!/usr/bin/perl use strict; use warnings; use Test::More; use Test::Fatal; use Moose::Util::TypeConstraints; is( exception { subtype 'MyCollections' => as 'ArrayRef | HashRef'; }, undef, '... created the subtype special okay' ); { my $t = find_type_constraint('MyCollections'); isa_ok($t, 'Moose::Meta::TypeConstraint'); is($t->name, 'MyCollections', '... name is correct'); my $p = $t->parent; isa_ok($p, 'Moose::Meta::TypeConstraint::Union'); isa_ok($p, 'Moose::Meta::TypeConstraint'); is($p->name, 'ArrayRef|HashRef', '... parent name is correct'); ok($t->check([]), '... validated it correctly'); ok($t->check({}), '... validated it correctly'); ok(!$t->check(1), '... validated it correctly'); } is( exception { subtype 'MyCollectionsExtended' => as 'ArrayRef|HashRef' => where { if (ref($_) eq 'ARRAY') { return if scalar(@$_) < 2; } elsif (ref($_) eq 'HASH') { return if scalar(keys(%$_)) < 2; } 1; }; }, undef, '... created the subtype special okay' ); { my $t = find_type_constraint('MyCollectionsExtended'); isa_ok($t, 'Moose::Meta::TypeConstraint'); is($t->name, 'MyCollectionsExtended', '... name is correct'); my $p = $t->parent; isa_ok($p, 'Moose::Meta::TypeConstraint::Union'); isa_ok($p, 'Moose::Meta::TypeConstraint'); is($p->name, 'ArrayRef|HashRef', '... parent name is correct'); ok(!$t->check([]), '... validated it correctly'); ok($t->check([1, 2]), '... validated it correctly'); ok(!$t->check({}), '... validated it correctly'); ok($t->check({ one => 1, two => 2 }), '... validated it correctly'); ok(!$t->check(1), '... validated it correctly'); } { my $union = Moose::Util::TypeConstraints::find_or_create_type_constraint('Int|ArrayRef[Int]'); subtype 'UnionSub', as 'Int|ArrayRef[Int]'; my $subtype = find_type_constraint('UnionSub'); ok( !$union->is_a_type_of('Ref'), 'Int|ArrayRef[Int] is not a type of Ref' ); ok( !$subtype->is_a_type_of('Ref'), 'subtype of Int|ArrayRef[Int] is not a type of Ref' ); ok( $union->is_a_type_of('Defined'), 'Int|ArrayRef[Int] is a type of Defined' ); ok( $subtype->is_a_type_of('Defined'), 'subtype of Int|ArrayRef[Int] is a type of Defined' ); ok( !$union->is_subtype_of('Ref'), 'Int|ArrayRef[Int] is not a subtype of Ref' ); ok( !$subtype->is_subtype_of('Ref'), 'subtype of Int|ArrayRef[Int] is not a subtype of Ref' ); ok( $union->is_subtype_of('Defined'), 'Int|ArrayRef[Int] is a subtype of Defined' ); ok( $subtype->is_subtype_of('Defined'), 'subtype of Int|ArrayRef[Int] is a subtype of Defined' ); } done_testing; util_type_constraints.t100644000767000024 2022412200352345 23062 0ustar00etherstaff000000000000Moose-2.1005/t/type_constraints#!/usr/bin/perl use strict; use warnings; use Test::More; use Test::Fatal; use Scalar::Util (); use Moose::Util::TypeConstraints; type Number => where { Scalar::Util::looks_like_number($_) }; type String => where { !ref($_) && !Number($_) } => message { "This is not a string ($_)" }; subtype Natural => as Number => where { $_ > 0 }; subtype NaturalLessThanTen => as Natural => where { $_ < 10 } => message { "The number '$_' is not less than 10" }; Moose::Util::TypeConstraints->export_type_constraints_as_functions(); ok(Number(5), '... this is a Num'); ok(!defined(Number('Foo')), '... this is not a Num'); { my $number_tc = Moose::Util::TypeConstraints::find_type_constraint('Number'); is("$number_tc", 'Number', '... type constraint stringifies to name'); } ok(String('Foo'), '... this is a Str'); ok(!defined(String(5)), '... this is not a Str'); ok(Natural(5), '... this is a Natural'); is(Natural(-5), undef, '... this is not a Natural'); is(Natural('Foo'), undef, '... this is not a Natural'); ok(NaturalLessThanTen(5), '... this is a NaturalLessThanTen'); is(NaturalLessThanTen(12), undef, '... this is not a NaturalLessThanTen'); is(NaturalLessThanTen(-5), undef, '... this is not a NaturalLessThanTen'); is(NaturalLessThanTen('Foo'), undef, '... this is not a NaturalLessThanTen'); # anon sub-typing my $negative = subtype Number => where { $_ < 0 }; ok(defined $negative, '... got a value back from negative'); isa_ok($negative, 'Moose::Meta::TypeConstraint'); ok($negative->check(-5), '... this is a negative number'); ok(!defined($negative->check(5)), '... this is not a negative number'); is($negative->check('Foo'), undef, '... this is not a negative number'); ok($negative->is_subtype_of('Number'), '... $negative is a subtype of Number'); ok(!$negative->is_subtype_of('String'), '... $negative is not a subtype of String'); my $negative2 = subtype Number => where { $_ < 0 } => message {"$_ is not a negative number"}; ok(defined $negative2, '... got a value back from negative'); isa_ok($negative2, 'Moose::Meta::TypeConstraint'); ok($negative2->check(-5), '... this is a negative number'); ok(!defined($negative2->check(5)), '... this is not a negative number'); is($negative2->check('Foo'), undef, '... this is not a negative number'); ok($negative2->is_subtype_of('Number'), '... $negative2 is a subtype of Number'); ok(!$negative2->is_subtype_of('String'), '... $negative is not a subtype of String'); ok($negative2->has_message, '... it has a message'); is($negative2->validate(2), '2 is not a negative number', '... validated unsuccessfully (got error)'); # check some meta-details my $natural_less_than_ten = find_type_constraint('NaturalLessThanTen'); isa_ok($natural_less_than_ten, 'Moose::Meta::TypeConstraint'); ok($natural_less_than_ten->is_subtype_of('Natural'), '... NaturalLessThanTen is subtype of Natural'); ok($natural_less_than_ten->is_subtype_of('Number'), '... NaturalLessThanTen is subtype of Number'); ok(!$natural_less_than_ten->is_subtype_of('String'), '... NaturalLessThanTen is not subtype of String'); ok($natural_less_than_ten->has_message, '... it has a message'); ok(!defined($natural_less_than_ten->validate(5)), '... validated successfully (no error)'); is($natural_less_than_ten->validate(15), "The number '15' is not less than 10", '... validated unsuccessfully (got error)'); my $natural = find_type_constraint('Natural'); isa_ok($natural, 'Moose::Meta::TypeConstraint'); ok($natural->is_subtype_of('Number'), '... Natural is a subtype of Number'); ok(!$natural->is_subtype_of('String'), '... Natural is not a subtype of String'); ok(!$natural->has_message, '... it does not have a message'); ok(!defined($natural->validate(5)), '... validated successfully (no error)'); is($natural->validate(-5), "Validation failed for 'Natural' with value -5", '... validated unsuccessfully (got error)'); my $string = find_type_constraint('String'); isa_ok($string, 'Moose::Meta::TypeConstraint'); ok($string->has_message, '... it does have a message'); ok(!defined($string->validate("Five")), '... validated successfully (no error)'); is($string->validate(5), "This is not a string (5)", '... validated unsuccessfully (got error)'); is( exception { Moose::Meta::Attribute->new('bob', isa => 'Spong') }, undef, 'meta-attr construction ok even when type constraint utils loaded first' ); # Test type constraint predicate return values. foreach my $predicate (qw/equals is_subtype_of is_a_type_of/) { ok( !defined $string->$predicate('DoesNotExist'), "$predicate predicate returns undef for non existant constraint"); } # Test adding things which don't look like types to the registry throws an exception my $r = Moose::Util::TypeConstraints->get_type_constraint_registry; like( exception {$r->add_type_constraint()}, qr/not a valid type constraint/, '->add_type_constraint(undef) throws' ); like( exception {$r->add_type_constraint('foo')}, qr/not a valid type constraint/, '->add_type_constraint("foo") throws' ); like( exception {$r->add_type_constraint(bless {}, 'SomeClass')}, qr/not a valid type constraint/, '->add_type_constraint(SomeClass->new) throws' ); # Test some specific things that in the past did not work, # specifically weird variations on anon subtypes. { my $subtype = subtype as 'Str'; isa_ok( $subtype, 'Moose::Meta::TypeConstraint', 'got an anon subtype' ); is( $subtype->parent->name, 'Str', 'parent is Str' ); # This test sucks but is the best we can do is( $subtype->constraint->(), 1, 'subtype has the null constraint' ); ok( ! $subtype->has_message, 'subtype has no message' ); } { my $subtype = subtype as 'ArrayRef[Num|Str]'; isa_ok( $subtype, 'Moose::Meta::TypeConstraint', 'got an anon subtype' ); is( $subtype->parent->name, 'ArrayRef[Num|Str]', 'parent is ArrayRef[Num|Str]' ); ok( ! $subtype->has_message, 'subtype has no message' ); } { my $subtype = subtype 'ArrayRef[Num|Str]' => message { 'foo' }; isa_ok( $subtype, 'Moose::Meta::TypeConstraint', 'got an anon subtype' ); is( $subtype->parent->name, 'ArrayRef[Num|Str]', 'parent is ArrayRef[Num|Str]' ); ok( $subtype->has_message, 'subtype does have a message' ); } # alternative sugar-less calling style which is documented as legit: { my $subtype = subtype( 'MyStr', { as => 'Str' } ); isa_ok( $subtype, 'Moose::Meta::TypeConstraint', 'got a subtype' ); is( $subtype->name, 'MyStr', 'name is MyStr' ); is( $subtype->parent->name, 'Str', 'parent is Str' ); } { my $subtype = subtype( { as => 'Str' } ); isa_ok( $subtype, 'Moose::Meta::TypeConstraint', 'got a subtype' ); is( $subtype->name, '__ANON__', 'name is __ANON__' ); is( $subtype->parent->name, 'Str', 'parent is Str' ); } { my $subtype = subtype( { as => 'Str', where => sub { /X/ } } ); isa_ok( $subtype, 'Moose::Meta::TypeConstraint', 'got a subtype' ); is( $subtype->name, '__ANON__', 'name is __ANON__' ); is( $subtype->parent->name, 'Str', 'parent is Str' ); ok( $subtype->check('FooX'), 'constraint accepts FooX' ); ok( ! $subtype->check('Foo'), 'constraint reject Foo' ); } { like( exception { subtype 'Foo' }, qr/cannot consist solely of a name/, 'Cannot call subtype with a single string argument' ); } { my $subtype = subtype( { as => 'Num' } ); isa_ok( $subtype, 'Moose::Meta::TypeConstraint', 'got a subtype' ); my @rejects = ( 'nan', 'inf', 'infinity', 'Infinity', 'NaN', 'INF', ' 1234 ', ' 123.44 ', ' 13e7 ', 'hello', "1e3\n", "52563\n", "123.4\n", '0.', "0 but true", undef ); my @accepts = ( '123', '123.4367', '3322', '13e7', '0', '0.0', '.0', .0, 0.0, 123, 13e6, 123.4367, 10.5 ); for( @rejects ) { my $printable = defined $_ ? $_ : "(undef)"; ok( !$subtype->check($_), "constraint rejects $printable" ) } ok( $subtype->check($_), "constraint accepts $_" ) for @accepts; } done_testing; meta_globref_instancemetaclass.t100644000767000024 706012200352345 22631 0ustar00etherstaff000000000000Moose-2.1005/t/recipes#!/usr/bin/perl -w use strict; use Test::More 'no_plan'; use Test::Fatal; $| = 1; # =begin testing SETUP { package My::Meta::Instance; use Moose; # This needs to be in a BEGIN block so to avoid a metaclass # incompatibility error from Moose. In normal usage, # My::Meta::Instance would be in a separate file from MyApp::User, # and this would be a non-issue. BEGIN { extends 'Moose::Meta::Instance' } } # =begin testing SETUP { package My::Meta::Instance; use Scalar::Util qw( weaken ); use Symbol qw( gensym ); use Moose; extends 'Moose::Meta::Instance'; sub create_instance { my $self = shift; my $sym = gensym(); bless $sym, $self->_class_name; } sub clone_instance { my ( $self, $instance ) = @_; my $new_sym = gensym(); %{*$new_sym} = %{*$instance}; bless $new_sym, $self->_class_name; } sub get_slot_value { my ( $self, $instance, $slot_name ) = @_; return *$instance->{$slot_name}; } sub set_slot_value { my ( $self, $instance, $slot_name, $value ) = @_; *$instance->{$slot_name} = $value; } sub deinitialize_slot { my ( $self, $instance, $slot_name ) = @_; delete *$instance->{$slot_name}; } sub is_slot_initialized { my ( $self, $instance, $slot_name ) = @_; exists *$instance->{$slot_name}; } sub weaken_slot_value { my ( $self, $instance, $slot_name ) = @_; weaken *$instance->{$slot_name}; } sub inline_create_instance { my ( $self, $class_variable ) = @_; return 'do { my $sym = Symbol::gensym(); bless $sym, ' . $class_variable . ' }'; } sub inline_slot_access { my ( $self, $instance, $slot_name ) = @_; return '*{' . $instance . '}->{' . $slot_name . '}'; } package MyApp::User; use metaclass 'Moose::Meta::Class' => ( instance_metaclass => 'My::Meta::Instance' ); use Moose; has 'name' => ( is => 'rw', isa => 'Str', ); has 'email' => ( is => 'rw', isa => 'Str', ); } # =begin testing { { package MyApp::Employee; use Moose; extends 'MyApp::User'; has 'employee_number' => ( is => 'rw' ); } for my $x ( 0 .. 1 ) { MyApp::User->meta->make_immutable if $x; my $user = MyApp::User->new( name => 'Faye', email => 'faye@example.com', ); ok( eval { *{$user} }, 'user object is an glob ref with some values' ); is( $user->name, 'Faye', 'check name' ); is( $user->email, 'faye@example.com', 'check email' ); $user->name('Ralph'); is( $user->name, 'Ralph', 'check name after changing it' ); $user->email('ralph@example.com'); is( $user->email, 'ralph@example.com', 'check email after changing it' ); } for my $x ( 0 .. 1 ) { MyApp::Employee->meta->make_immutable if $x; my $emp = MyApp::Employee->new( name => 'Faye', email => 'faye@example.com', employee_number => $x, ); ok( eval { *{$emp} }, 'employee object is an glob ref with some values' ); is( $emp->name, 'Faye', 'check name' ); is( $emp->email, 'faye@example.com', 'check email' ); is( $emp->employee_number, $x, 'check employee_number' ); $emp->name('Ralph'); is( $emp->name, 'Ralph', 'check name after changing it' ); $emp->email('ralph@example.com'); is( $emp->email, 'ralph@example.com', 'check email after changing it' ); $emp->employee_number(42); is( $emp->employee_number, 42, 'check employee_number after changing it' ); } } 1; delegation_target_not_loaded.t100644000767000024 145112200352345 23025 0ustar00etherstaff000000000000Moose-2.1005/t/attributesuse strict; use warnings; use Test::More; use Test::Fatal; { package X; use Moose; ::like( ::exception{ has foo => ( is => 'ro', isa => 'Foo', handles => qr/.*/, ) }, qr/\QThe foo attribute is trying to delegate to a class which has not been loaded - Foo/, 'cannot delegate to a class which is not yet loaded' ); ::like( ::exception{ has foo => ( is => 'ro', does => 'Role::Foo', handles => qr/.*/, ) }, qr/\QThe foo attribute is trying to delegate to a role which has not been loaded - Role::Foo/, 'cannot delegate to a role which is not yet loaded' ); } done_testing; custom_attr_meta_with_roles.t100644000767000024 116612200352345 23106 0ustar00etherstaff000000000000Moose-2.1005/t/metaclasses#!/usr/bin/perl use strict; use warnings; use Test::More; { package My::Custom::Meta::Attr; use Moose; extends 'Moose::Meta::Attribute'; } { package My::Fancy::Role; use Moose::Role; has 'bling_bling' => ( metaclass => 'My::Custom::Meta::Attr', is => 'rw', isa => 'Str', ); } { package My::Class; use Moose; with 'My::Fancy::Role'; } my $c = My::Class->new; isa_ok($c, 'My::Class'); ok($c->meta->has_attribute('bling_bling'), '... got the attribute'); isa_ok($c->meta->get_attribute('bling_bling'), 'My::Custom::Meta::Attr'); done_testing; advanced_type_creation.t100644000767000024 1013412200352345 23106 0ustar00etherstaff000000000000Moose-2.1005/t/type_constraints#!/usr/bin/perl use strict; use warnings; use Test::More; use Moose::Util::TypeConstraints; use Moose::Meta::TypeConstraint::Parameterized; my $r = Moose::Util::TypeConstraints->get_type_constraint_registry; ## Containers in unions ... # Array of Ints or Strings my $array_of_ints_or_strings = Moose::Util::TypeConstraints::create_parameterized_type_constraint('ArrayRef[Int|Str]'); isa_ok($array_of_ints_or_strings, 'Moose::Meta::TypeConstraint::Parameterized'); ok($array_of_ints_or_strings->check([ 1, 'two', 3 ]), '... this passed the type check'); ok($array_of_ints_or_strings->check([ 1, 2, 3 ]), '... this passed the type check'); ok($array_of_ints_or_strings->check([ 'one', 'two', 'three' ]), '... this passed the type check'); ok(!$array_of_ints_or_strings->check([ 1, [], 'three' ]), '... this didnt pass the type check'); $r->add_type_constraint($array_of_ints_or_strings); # Array of Ints or HashRef my $array_of_ints_or_hash_ref = Moose::Util::TypeConstraints::create_parameterized_type_constraint('ArrayRef[Int | HashRef]'); isa_ok($array_of_ints_or_hash_ref, 'Moose::Meta::TypeConstraint::Parameterized'); ok($array_of_ints_or_hash_ref->check([ 1, {}, 3 ]), '... this passed the type check'); ok($array_of_ints_or_hash_ref->check([ 1, 2, 3 ]), '... this passed the type check'); ok($array_of_ints_or_hash_ref->check([ {}, {}, {} ]), '... this passed the type check'); ok(!$array_of_ints_or_hash_ref->check([ {}, [], 3 ]), '... this didnt pass the type check'); $r->add_type_constraint($array_of_ints_or_hash_ref); # union of Arrays of Str | Int or Arrays of Int | Hash # we can't build this using the simplistic parser # we have, so we have to do it by hand - SL my $pure_insanity = Moose::Util::TypeConstraints::create_type_constraint_union('ArrayRef[Int|Str] | ArrayRef[Int | HashRef]'); isa_ok($pure_insanity, 'Moose::Meta::TypeConstraint::Union'); ok($pure_insanity->check([ 1, {}, 3 ]), '... this passed the type check'); ok($pure_insanity->check([ 1, 'Str', 3 ]), '... this passed the type check'); ok(!$pure_insanity->check([ 1, {}, 'foo' ]), '... this didnt pass the type check'); ok(!$pure_insanity->check([ [], {}, 1 ]), '... this didnt pass the type check'); ## Nested Containers ... # Array of Ints my $array_of_ints = Moose::Util::TypeConstraints::create_parameterized_type_constraint('ArrayRef[Int]'); isa_ok($array_of_ints, 'Moose::Meta::TypeConstraint::Parameterized'); isa_ok($array_of_ints, 'Moose::Meta::TypeConstraint'); ok($array_of_ints->check([ 1, 2, 3, 4 ]), '... [ 1, 2, 3, 4 ] passed successfully'); ok(!$array_of_ints->check([qw/foo bar baz/]), '... [qw/foo bar baz/] failed successfully'); ok(!$array_of_ints->check([ 1, 2, 3, qw/foo bar/]), '... [ 1, 2, 3, qw/foo bar/] failed successfully'); ok(!$array_of_ints->check(1), '... 1 failed successfully'); ok(!$array_of_ints->check({}), '... {} failed successfully'); ok(!$array_of_ints->check(sub { () }), '... sub { () } failed successfully'); # Array of Array of Ints my $array_of_array_of_ints = Moose::Util::TypeConstraints::create_parameterized_type_constraint('ArrayRef[ArrayRef[Int]]'); isa_ok($array_of_array_of_ints, 'Moose::Meta::TypeConstraint::Parameterized'); isa_ok($array_of_array_of_ints, 'Moose::Meta::TypeConstraint'); ok($array_of_array_of_ints->check( [[ 1, 2, 3 ], [ 4, 5, 6 ]] ), '... [[ 1, 2, 3 ], [ 4, 5, 6 ]] passed successfully'); ok(!$array_of_array_of_ints->check( [[ 1, 2, 3 ], [ qw/foo bar/ ]] ), '... [[ 1, 2, 3 ], [ qw/foo bar/ ]] failed successfully'); # Array of Array of Array of Ints my $array_of_array_of_array_of_ints = Moose::Util::TypeConstraints::create_parameterized_type_constraint('ArrayRef[ArrayRef[ArrayRef[Int]]]'); isa_ok($array_of_array_of_array_of_ints, 'Moose::Meta::TypeConstraint::Parameterized'); isa_ok($array_of_array_of_array_of_ints, 'Moose::Meta::TypeConstraint'); ok($array_of_array_of_array_of_ints->check( [[[ 1, 2, 3 ], [ 4, 5, 6 ]], [[ 7, 8, 9 ]]] ), '... [[[ 1, 2, 3 ], [ 4, 5, 6 ]], [[ 7, 8, 9 ]]] passed successfully'); ok(!$array_of_array_of_array_of_ints->check( [[[ 1, 2, 3 ]], [[ qw/foo bar/ ]]] ), '... [[[ 1, 2, 3 ]], [[ qw/foo bar/ ]]] failed successfully'); done_testing; basics_http_subtypesandcoercion.t100644000767000024 637012200352345 23073 0ustar00etherstaff000000000000Moose-2.1005/t/recipes#!/usr/bin/perl -w use strict; use Test::More 'no_plan'; use Test::Fatal; $| = 1; # =begin testing SETUP use Test::Requires { 'HTTP::Headers' => '0', 'Params::Coerce' => '0', 'URI' => '0', }; # =begin testing SETUP { package Request; use Moose; use Moose::Util::TypeConstraints; use HTTP::Headers (); use Params::Coerce (); use URI (); subtype 'My::Types::HTTP::Headers' => as class_type('HTTP::Headers'); coerce 'My::Types::HTTP::Headers' => from 'ArrayRef' => via { HTTP::Headers->new( @{$_} ) } => from 'HashRef' => via { HTTP::Headers->new( %{$_} ) }; subtype 'My::Types::URI' => as class_type('URI'); coerce 'My::Types::URI' => from 'Object' => via { $_->isa('URI') ? $_ : Params::Coerce::coerce( 'URI', $_ ); } => from 'Str' => via { URI->new( $_, 'http' ) }; subtype 'Protocol' => as 'Str' => where { /^HTTP\/[0-9]\.[0-9]$/ }; has 'base' => ( is => 'rw', isa => 'My::Types::URI', coerce => 1 ); has 'uri' => ( is => 'rw', isa => 'My::Types::URI', coerce => 1 ); has 'method' => ( is => 'rw', isa => 'Str' ); has 'protocol' => ( is => 'rw', isa => 'Protocol' ); has 'headers' => ( is => 'rw', isa => 'My::Types::HTTP::Headers', coerce => 1, default => sub { HTTP::Headers->new } ); } # =begin testing { my $r = Request->new; isa_ok( $r, 'Request' ); { my $header = $r->headers; isa_ok( $header, 'HTTP::Headers' ); is( $r->headers->content_type, '', '... got no content type in the header' ); $r->headers( { content_type => 'text/plain' } ); my $header2 = $r->headers; isa_ok( $header2, 'HTTP::Headers' ); isnt( $header, $header2, '... created a new HTTP::Header object' ); is( $header2->content_type, 'text/plain', '... got the right content type in the header' ); $r->headers( [ content_type => 'text/html' ] ); my $header3 = $r->headers; isa_ok( $header3, 'HTTP::Headers' ); isnt( $header2, $header3, '... created a new HTTP::Header object' ); is( $header3->content_type, 'text/html', '... got the right content type in the header' ); $r->headers( HTTP::Headers->new( content_type => 'application/pdf' ) ); my $header4 = $r->headers; isa_ok( $header4, 'HTTP::Headers' ); isnt( $header3, $header4, '... created a new HTTP::Header object' ); is( $header4->content_type, 'application/pdf', '... got the right content type in the header' ); isnt( exception { $r->headers('Foo'); }, undef, '... dies when it gets bad params' ); } { is( $r->protocol, undef, '... got nothing by default' ); is( exception { $r->protocol('HTTP/1.0'); }, undef, '... set the protocol correctly' ); is( $r->protocol, 'HTTP/1.0', '... got nothing by default' ); isnt( exception { $r->protocol('http/1.0'); }, undef, '... the protocol died with bar params correctly' ); } { $r->base('http://localhost/'); isa_ok( $r->base, 'URI' ); $r->uri('http://localhost/'); isa_ok( $r->uri, 'URI' ); } } 1; meta_labeled_attributemetaclass.t100644000767000024 302312200352345 22773 0ustar00etherstaff000000000000Moose-2.1005/t/recipes#!/usr/bin/perl -w use strict; use Test::More 'no_plan'; use Test::Fatal; $| = 1; # =begin testing SETUP { package MyApp::Meta::Attribute::Labeled; use Moose; extends 'Moose::Meta::Attribute'; has label => ( is => 'rw', isa => 'Str', predicate => 'has_label', ); package Moose::Meta::Attribute::Custom::Labeled; sub register_implementation {'MyApp::Meta::Attribute::Labeled'} package MyApp::Website; use Moose; has url => ( metaclass => 'Labeled', is => 'rw', isa => 'Str', label => "The site's URL", ); has name => ( is => 'rw', isa => 'Str', ); sub dump { my $self = shift; my $meta = $self->meta; my $dump = ''; for my $attribute ( map { $meta->get_attribute($_) } sort $meta->get_attribute_list ) { if ( $attribute->isa('MyApp::Meta::Attribute::Labeled') && $attribute->has_label ) { $dump .= $attribute->label; } else { $dump .= $attribute->name; } my $reader = $attribute->get_read_method; $dump .= ": " . $self->$reader . "\n"; } return $dump; } package main; my $app = MyApp::Website->new( url => "http://google.com", name => "Google" ); } # =begin testing { my $app = MyApp::Website->new( url => "http://google.com", name => "Google" ); is( $app->dump, q{name: Google The site's URL: http://google.com }, '... got the expected dump value' ); } 1; Point3D.pm100644000767000024 44312200352345 22327 0ustar00etherstaff000000000000Moose-2.1005/benchmarks/cmop/lib/MOP/Immutable package MOP::Immutable::Point3D; use strict; use warnings; use metaclass; use base 'MOP::Point'; __PACKAGE__->meta->add_attribute('z' => (accessor => 'z')); sub clear { my $self = shift; $self->SUPER::clear(); $self->z(0); } __PACKAGE__->meta->make_immutable; 1; __END__ Point3D.pm100644000767000024 42612200352345 22330 0ustar00etherstaff000000000000Moose-2.1005/benchmarks/cmop/lib/MOP/Installed use lib reverse @INC; package MOP::Installed::Point3D; use strict; use warnings; use metaclass; use base 'MOP::Point'; __PACKAGE__->meta->add_attribute('z' => (accessor => 'z')); sub clear { my $self = shift; $self->SUPER::clear(); $self->z(0); } 1; __END__ attribute_accessor_generation.t100644000767000024 1277612200352345 23310 0ustar00etherstaff000000000000Moose-2.1005/t/attributes#!/usr/bin/perl use strict; use warnings; use Test::More; use Test::Fatal; use Scalar::Util 'isweak'; { package Foo; use Moose; eval { has 'foo' => ( accessor => 'foo', ); }; ::ok(!$@, '... created the accessor method okay'); eval { has 'lazy_foo' => ( accessor => 'lazy_foo', lazy => 1, default => sub { 10 } ); }; ::ok(!$@, '... created the lazy accessor method okay'); eval { has 'foo_required' => ( accessor => 'foo_required', required => 1, ); }; ::ok(!$@, '... created the required accessor method okay'); eval { has 'foo_int' => ( accessor => 'foo_int', isa => 'Int', ); }; ::ok(!$@, '... created the accessor method with type constraint okay'); eval { has 'foo_weak' => ( accessor => 'foo_weak', weak_ref => 1 ); }; ::ok(!$@, '... created the accessor method with weak_ref okay'); eval { has 'foo_deref' => ( accessor => 'foo_deref', isa => 'ArrayRef', auto_deref => 1, ); }; ::ok(!$@, '... created the accessor method with auto_deref okay'); eval { has 'foo_deref_ro' => ( reader => 'foo_deref_ro', isa => 'ArrayRef', auto_deref => 1, ); }; ::ok(!$@, '... created the reader method with auto_deref okay'); eval { has 'foo_deref_hash' => ( accessor => 'foo_deref_hash', isa => 'HashRef', auto_deref => 1, ); }; ::ok(!$@, '... created the reader method with auto_deref okay'); } { my $foo = Foo->new(foo_required => 'required'); isa_ok($foo, 'Foo'); # regular accessor can_ok($foo, 'foo'); is($foo->foo(), undef, '... got an unset value'); is( exception { $foo->foo(100); }, undef, '... foo wrote successfully' ); is($foo->foo(), 100, '... got the correct set value'); ok(!isweak($foo->{foo}), '... it is not a weak reference'); # required writer isnt( exception { Foo->new; }, undef, '... cannot create without the required attribute' ); can_ok($foo, 'foo_required'); is($foo->foo_required(), 'required', '... got an unset value'); is( exception { $foo->foo_required(100); }, undef, '... foo_required wrote successfully' ); is($foo->foo_required(), 100, '... got the correct set value'); is( exception { $foo->foo_required(undef); }, undef, '... foo_required did not die with undef' ); is($foo->foo_required, undef, "value is undef"); ok(!isweak($foo->{foo_required}), '... it is not a weak reference'); # lazy ok(!exists($foo->{lazy_foo}), '... no value in lazy_foo slot'); can_ok($foo, 'lazy_foo'); is($foo->lazy_foo(), 10, '... got an deferred value'); # with type constraint can_ok($foo, 'foo_int'); is($foo->foo_int(), undef, '... got an unset value'); is( exception { $foo->foo_int(100); }, undef, '... foo_int wrote successfully' ); is($foo->foo_int(), 100, '... got the correct set value'); isnt( exception { $foo->foo_int("Foo"); }, undef, '... foo_int died successfully' ); ok(!isweak($foo->{foo_int}), '... it is not a weak reference'); # with weak_ref my $test = []; can_ok($foo, 'foo_weak'); is($foo->foo_weak(), undef, '... got an unset value'); is( exception { $foo->foo_weak($test); }, undef, '... foo_weak wrote successfully' ); is($foo->foo_weak(), $test, '... got the correct set value'); ok(isweak($foo->{foo_weak}), '... it is a weak reference'); can_ok( $foo, 'foo_deref'); is_deeply( [$foo->foo_deref()], [], '... default default value'); my @list; is( exception { @list = $foo->foo_deref(); }, undef, "... doesn't deref undef value" ); is_deeply( \@list, [], "returns empty list in list context"); is( exception { $foo->foo_deref( [ qw/foo bar gorch/ ] ); }, undef, '... foo_deref wrote successfully' ); is( Scalar::Util::reftype( scalar $foo->foo_deref() ), "ARRAY", "returns an array reference in scalar context" ); is_deeply( scalar($foo->foo_deref()), [ qw/foo bar gorch/ ], "correct array" ); is( scalar( () = $foo->foo_deref() ), 3, "returns list in list context" ); is_deeply( [ $foo->foo_deref() ], [ qw/foo bar gorch/ ], "correct list" ); can_ok( $foo, 'foo_deref' ); is_deeply( [$foo->foo_deref_ro()], [], "... default default value" ); isnt( exception { $foo->foo_deref_ro( [] ); }, undef, "... read only" ); $foo->{foo_deref_ro} = [qw/la la la/]; is_deeply( scalar($foo->foo_deref_ro()), [qw/la la la/], "scalar context ro" ); is_deeply( [ $foo->foo_deref_ro() ], [qw/la la la/], "list context ro" ); can_ok( $foo, 'foo_deref_hash' ); is_deeply( { $foo->foo_deref_hash() }, {}, "... default default value" ); my %hash; is( exception { %hash = $foo->foo_deref_hash(); }, undef, "... doesn't deref undef value" ); is_deeply( \%hash, {}, "returns empty list in list context"); is( exception { $foo->foo_deref_hash( { foo => 1, bar => 2 } ); }, undef, '... foo_deref_hash wrote successfully' ); is_deeply( scalar($foo->foo_deref_hash), { foo => 1, bar => 2 }, "scalar context" ); %hash = $foo->foo_deref_hash; is_deeply( \%hash, { foo => 1, bar => 2 }, "list context"); } done_testing; attribute_without_any_methods.t100644000767000024 72412200352345 23316 0ustar00etherstaff000000000000Moose-2.1005/t/attributes#!/usr/bin/perl use strict; use warnings; use Test::More; use Moose (); use Moose::Meta::Class; my $meta = Moose::Meta::Class->create('Banana'); my $warn; $SIG{__WARN__} = sub { $warn = "@_" }; $meta->add_attribute('foo'); like $warn, qr/Attribute \(foo\) of class Banana has no associated methods/, 'correct error message'; $warn = ''; $meta->add_attribute('bar', is => 'bare'); is $warn, '', 'add attribute with no methods and is => "bare"'; done_testing; moose_exporter_trait_aliases.t100644000767000024 374312200352345 23256 0ustar00etherstaff000000000000Moose-2.1005/t/metaclasses#!/usr/bin/env perl use strict; use warnings; use Test::More; use Test::Moose; { package Attribute::Trait::Awesome; use Moose::Role; } BEGIN { package Awesome::Exporter; use Moose::Exporter; Moose::Exporter->setup_import_methods( trait_aliases => ['Attribute::Trait::Awesome'], ); } { package Awesome; use Moose; BEGIN { Awesome::Exporter->import } has foo => ( traits => [Awesome], is => 'ro', ); ::does_ok(__PACKAGE__->meta->get_attribute('foo'), 'Attribute::Trait::Awesome'); no Moose; BEGIN { Awesome::Exporter->unimport } my $val = eval "Awesome"; ::like($@, qr/Bareword "Awesome" not allowed/, "unimported properly"); ::is($val, undef, "unimported properly"); } BEGIN { package Awesome2::Exporter; use Moose::Exporter; Moose::Exporter->setup_import_methods( trait_aliases => [ [ 'Attribute::Trait::Awesome' => 'Awesome2' ], ], ); } { package Awesome2; use Moose; BEGIN { Awesome2::Exporter->import } has foo => ( traits => [Awesome2], is => 'ro', ); ::does_ok(__PACKAGE__->meta->get_attribute('foo'), 'Attribute::Trait::Awesome'); BEGIN { Awesome2::Exporter->unimport } my $val = eval "Awesome2"; ::like($@, qr/Bareword "Awesome2" not allowed/, "unimported properly"); ::is($val, undef, "unimported properly"); } { package Awesome2::Rename; use Moose; BEGIN { Awesome2::Exporter->import(Awesome2 => { -as => 'emosewA' }) } has foo => ( traits => [emosewA], is => 'ro', ); ::does_ok(__PACKAGE__->meta->get_attribute('foo'), 'Attribute::Trait::Awesome'); BEGIN { Awesome2::Exporter->unimport } { our $TODO; local $TODO = "unimporting renamed subs currently doesn't work"; my $val = eval "emosewA"; ::like($@, qr/Bareword "emosewA" not allowed/, "unimported properly"); ::is($val, undef, "unimported properly"); } } done_testing; container_type_coercion.t100644000767000024 322512200352345 23303 0ustar00etherstaff000000000000Moose-2.1005/t/type_constraints#!/usr/bin/perl use strict; use warnings; use Test::More; use Moose::Util::TypeConstraints; use Moose::Meta::TypeConstraint::Parameterized; my $r = Moose::Util::TypeConstraints->get_type_constraint_registry; # Array of Ints my $array_of_ints = Moose::Meta::TypeConstraint::Parameterized->new( name => 'ArrayRef[Int]', parent => find_type_constraint('ArrayRef'), type_parameter => find_type_constraint('Int'), ); isa_ok($array_of_ints, 'Moose::Meta::TypeConstraint::Parameterized'); isa_ok($array_of_ints, 'Moose::Meta::TypeConstraint'); $r->add_type_constraint($array_of_ints); is(find_type_constraint('ArrayRef[Int]'), $array_of_ints, '... found the type we just added'); # Hash of Ints my $hash_of_ints = Moose::Meta::TypeConstraint::Parameterized->new( name => 'HashRef[Int]', parent => find_type_constraint('HashRef'), type_parameter => find_type_constraint('Int'), ); isa_ok($hash_of_ints, 'Moose::Meta::TypeConstraint::Parameterized'); isa_ok($hash_of_ints, 'Moose::Meta::TypeConstraint'); $r->add_type_constraint($hash_of_ints); is(find_type_constraint('HashRef[Int]'), $hash_of_ints, '... found the type we just added'); ## now attempt a coercion { package Foo; use Moose; use Moose::Util::TypeConstraints; coerce 'ArrayRef[Int]' => from 'HashRef[Int]' => via { [ values %$_ ] }; has 'bar' => ( is => 'ro', isa => 'ArrayRef[Int]', coerce => 1, ); } my $foo = Foo->new(bar => { one => 1, two => 2, three => 3 }); isa_ok($foo, 'Foo'); is_deeply([ sort @{$foo->bar} ], [ 1, 2, 3 ], '... our coercion worked!'); done_testing; util_more_type_coercion.t100644000767000024 702312200352345 23320 0ustar00etherstaff000000000000Moose-2.1005/t/type_constraints#!/usr/bin/perl use strict; use warnings; use Test::More; use Test::Fatal; { package HTTPHeader; use Moose; use Moose::Util::TypeConstraints; coerce 'HTTPHeader' => from ArrayRef => via { HTTPHeader->new(array => $_[0]) }; coerce 'HTTPHeader' => from HashRef => via { HTTPHeader->new(hash => $_[0]) }; has 'array' => (is => 'ro'); has 'hash' => (is => 'ro'); package Engine; use strict; use warnings; use Moose; has 'header' => (is => 'rw', isa => 'HTTPHeader', coerce => 1); } { my $engine = Engine->new(); isa_ok($engine, 'Engine'); # try with arrays is( exception { $engine->header([ 1, 2, 3 ]); }, undef, '... type was coerced without incident' ); isa_ok($engine->header, 'HTTPHeader'); is_deeply( $engine->header->array, [ 1, 2, 3 ], '... got the right array value of the header'); ok(!defined($engine->header->hash), '... no hash value set'); # try with hash is( exception { $engine->header({ one => 1, two => 2, three => 3 }); }, undef, '... type was coerced without incident' ); isa_ok($engine->header, 'HTTPHeader'); is_deeply( $engine->header->hash, { one => 1, two => 2, three => 3 }, '... got the right hash value of the header'); ok(!defined($engine->header->array), '... no array value set'); isnt( exception { $engine->header("Foo"); }, undef, '... dies with the wrong type, even after coercion' ); is( exception { $engine->header(HTTPHeader->new); }, undef, '... lives with the right type, even after coercion' ); } { my $engine = Engine->new(header => [ 1, 2, 3 ]); isa_ok($engine, 'Engine'); isa_ok($engine->header, 'HTTPHeader'); is_deeply( $engine->header->array, [ 1, 2, 3 ], '... got the right array value of the header'); ok(!defined($engine->header->hash), '... no hash value set'); } { my $engine = Engine->new(header => { one => 1, two => 2, three => 3 }); isa_ok($engine, 'Engine'); isa_ok($engine->header, 'HTTPHeader'); is_deeply( $engine->header->hash, { one => 1, two => 2, three => 3 }, '... got the right hash value of the header'); ok(!defined($engine->header->array), '... no array value set'); } { my $engine = Engine->new(header => HTTPHeader->new()); isa_ok($engine, 'Engine'); isa_ok($engine->header, 'HTTPHeader'); ok(!defined($engine->header->hash), '... no hash value set'); ok(!defined($engine->header->array), '... no array value set'); } isnt( exception { Engine->new(header => 'Foo'); }, undef, '... dies correctly with bad params' ); isnt( exception { Engine->new(header => \(my $var)); }, undef, '... dies correctly with bad params' ); { my $tc = Moose::Util::TypeConstraints::find_type_constraint('HTTPHeader'); isa_ok($tc, 'Moose::Meta::TypeConstraint', 'HTTPHeader TC'); my $from_aref = $tc->assert_coerce([ 1, 2, 3 ]); isa_ok($from_aref, 'HTTPHeader', 'assert_coerce from aref to HTTPHeader'); is_deeply($from_aref->array, [ 1, 2, 3 ], '...and has the right guts'); my $from_href = $tc->assert_coerce({ a => 1 }); isa_ok($from_href, 'HTTPHeader', 'assert_coerce from href to HTTPHeader'); is_deeply($from_href->hash, { a => 1 }, '...and has the right guts'); like( exception { $tc->assert_coerce('total garbage') }, qr/Validation failed for .HTTPHeader./, "assert_coerce throws if result is not acceptable" ); } done_testing; Trait000755000767000024 012200352345 21167 5ustar00etherstaff000000000000Moose-2.1005/lib/Moose/Meta/Attribute/NativeBool.pm100644000767000024 423312200352345 22562 0ustar00etherstaff000000000000Moose-2.1005/lib/Moose/Meta/Attribute/Native/Traitpackage Moose::Meta::Attribute::Native::Trait::Bool; BEGIN { $Moose::Meta::Attribute::Native::Trait::Bool::AUTHORITY = 'cpan:STEVAN'; } { $Moose::Meta::Attribute::Native::Trait::Bool::VERSION = '2.1005'; } use Moose::Role; with 'Moose::Meta::Attribute::Native::Trait'; sub _default_is { 'rw' } sub _helper_type { 'Bool' } no Moose::Role; 1; # ABSTRACT: Helper trait for Bool attributes __END__ =pod =head1 NAME Moose::Meta::Attribute::Native::Trait::Bool - Helper trait for Bool attributes =head1 VERSION version 2.1005 =head1 SYNOPSIS package Room; use Moose; has 'is_lit' => ( traits => ['Bool'], is => 'rw', isa => 'Bool', default => 0, handles => { illuminate => 'set', darken => 'unset', flip_switch => 'toggle', is_dark => 'not', }, ); my $room = Room->new(); $room->illuminate; # same as $room->is_lit(1); $room->darken; # same as $room->is_lit(0); $room->flip_switch; # same as $room->is_lit(not $room->is_lit); return $room->is_dark; # same as !$room->is_lit =head1 DESCRIPTION This trait provides native delegation methods for boolean values. A boolean is a scalar which can be C<1>, C<0>, C<"">, or C. =head1 DEFAULT TYPE If you don't provide an C value for your attribute, it will default to C. =head1 PROVIDED METHODS None of these methods accept arguments. =over 4 =item * B Sets the value to C<1> and returns C<1>. =item * B Set the value to C<0> and returns C<0>. =item * B Toggles the value. If it's true, set to false, and vice versa. Returns the new value. =item * B Equivalent of 'not C<$value>'. =back =head1 BUGS See L for details on reporting bugs. =head1 AUTHOR Moose is maintained by the Moose Cabal, along with the help of many contributors. See L and L for details. =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2013 by Infinity Interactive, Inc.. This is free software; you can redistribute it and/or modify it under the same terms as the Perl 5 programming language system itself. =cut Code.pm100644000767000024 326312200352345 22543 0ustar00etherstaff000000000000Moose-2.1005/lib/Moose/Meta/Attribute/Native/Traitpackage Moose::Meta::Attribute::Native::Trait::Code; BEGIN { $Moose::Meta::Attribute::Native::Trait::Code::AUTHORITY = 'cpan:STEVAN'; } { $Moose::Meta::Attribute::Native::Trait::Code::VERSION = '2.1005'; } use Moose::Role; with 'Moose::Meta::Attribute::Native::Trait'; sub _helper_type { 'CodeRef' } no Moose::Role; 1; # ABSTRACT: Helper trait for CodeRef attributes __END__ =pod =head1 NAME Moose::Meta::Attribute::Native::Trait::Code - Helper trait for CodeRef attributes =head1 VERSION version 2.1005 =head1 SYNOPSIS package Foo; use Moose; has 'callback' => ( traits => ['Code'], is => 'ro', isa => 'CodeRef', default => sub { sub { print "called" } }, handles => { call => 'execute', }, ); my $foo = Foo->new; $foo->call; # prints "called" =head1 DESCRIPTION This trait provides native delegation methods for code references. =head1 DEFAULT TYPE If you don't provide an C value for your attribute, it will default to C. =head1 PROVIDED METHODS =over 4 =item * B Calls the coderef with the given args. =item * B Calls the coderef with the instance as invocant and given args. =back =head1 BUGS See L for details on reporting bugs. =head1 AUTHOR Moose is maintained by the Moose Cabal, along with the help of many contributors. See L and L for details. =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2013 by Infinity Interactive, Inc.. This is free software; you can redistribute it and/or modify it under the same terms as the Perl 5 programming language system itself. =cut Hash.pm100644000767000024 1022112200352345 22564 0ustar00etherstaff000000000000Moose-2.1005/lib/Moose/Meta/Attribute/Native/Trait package Moose::Meta::Attribute::Native::Trait::Hash; BEGIN { $Moose::Meta::Attribute::Native::Trait::Hash::AUTHORITY = 'cpan:STEVAN'; } { $Moose::Meta::Attribute::Native::Trait::Hash::VERSION = '2.1005'; } use Moose::Role; with 'Moose::Meta::Attribute::Native::Trait'; sub _helper_type { 'HashRef' } no Moose::Role; 1; # ABSTRACT: Helper trait for HashRef attributes __END__ =pod =head1 NAME Moose::Meta::Attribute::Native::Trait::Hash - Helper trait for HashRef attributes =head1 VERSION version 2.1005 =head1 SYNOPSIS package Stuff; use Moose; has 'options' => ( traits => ['Hash'], is => 'ro', isa => 'HashRef[Str]', default => sub { {} }, handles => { set_option => 'set', get_option => 'get', has_no_options => 'is_empty', num_options => 'count', delete_option => 'delete', option_pairs => 'kv', }, ); =head1 DESCRIPTION This trait provides native delegation methods for hash references. =head1 PROVIDED METHODS =over 4 =item B Returns values from the hash. In list context it returns a list of values in the hash for the given keys. In scalar context it returns the value for the last key specified. This method requires at least one argument. =item B $value, $key2 =E $value2...)> Sets the elements in the hash to the given values. It returns the new values set for each key, in the same order as the keys passed to the method. This method requires at least two arguments, and expects an even number of arguments. =item B Removes the elements with the given keys. In list context it returns a list of values in the hash for the deleted keys. In scalar context it returns the value for the last key specified. =item B Returns the list of keys in the hash. This method does not accept any arguments. =item B Returns true if the given key is present in the hash. This method requires a single argument. =item B Returns true if the value of a given key is defined. This method requires a single argument. =item B Returns the list of values in the hash. This method does not accept any arguments. =item B Returns the key/value pairs in the hash as an array of array references. for my $pair ( $object->option_pairs ) { print "$pair->[0] = $pair->[1]\n"; } This method does not accept any arguments. =item B Returns the key/value pairs in the hash as a flattened list.. This method does not accept any arguments. =item B Resets the hash to an empty value, like C<%hash = ()>. This method does not accept any arguments. =item B Returns the number of elements in the hash. Also useful for not empty: C<< has_options => 'count' >>. This method does not accept any arguments. =item B If the hash is populated, returns false. Otherwise, returns true. This method does not accept any arguments. =item B =item B If passed one argument, returns the value of the specified key. If passed two arguments, sets the value of the specified key. When called as a setter, this method returns the value that was set. =item B This method returns a shallow clone of the hash reference. The return value is a reference to a new hash with the same keys and values. It is I because any values that were references in the original will be the I references in the clone. =back Note that C is deliberately omitted, due to its stateful interaction with the hash iterator. C or C are much safer. =head1 METHODS =over 4 =item B =back =head1 BUGS See L for details on reporting bugs. =head1 AUTHOR Moose is maintained by the Moose Cabal, along with the help of many contributors. See L and L for details. =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2013 by Infinity Interactive, Inc.. This is free software; you can redistribute it and/or modify it under the same terms as the Perl 5 programming language system itself. =cut Native000755000767000024 012200352345 21123 5ustar00etherstaff000000000000Moose-2.1005/lib/Moose/Meta/Method/AccessorHash.pm100644000767000024 113512200352345 22504 0ustar00etherstaff000000000000Moose-2.1005/lib/Moose/Meta/Method/Accessor/Nativepackage Moose::Meta::Method::Accessor::Native::Hash; BEGIN { $Moose::Meta::Method::Accessor::Native::Hash::AUTHORITY = 'cpan:STEVAN'; } { $Moose::Meta::Method::Accessor::Native::Hash::VERSION = '2.1005'; } use strict; use warnings; use Moose::Role; sub _inline_check_var_is_valid_key { my $self = shift; my ($var) = @_; return ( 'if (!defined(' . $var . ')) {', $self->_inline_throw_error( '"The key passed to ' . $self->delegate_to_method . ' must be a defined value"', ) . ';', '}', ); } no Moose::Role; 1; ToInstance.pm100644000767000024 374612200352345 22636 0ustar00etherstaff000000000000Moose-2.1005/lib/Moose/Meta/Role/Applicationpackage Moose::Meta::Role::Application::ToInstance; BEGIN { $Moose::Meta::Role::Application::ToInstance::AUTHORITY = 'cpan:STEVAN'; } { $Moose::Meta::Role::Application::ToInstance::VERSION = '2.1005'; } use strict; use warnings; use metaclass; use Scalar::Util 'blessed'; use List::MoreUtils 'all'; use base 'Moose::Meta::Role::Application'; __PACKAGE__->meta->add_attribute('rebless_params' => ( reader => 'rebless_params', default => sub { {} }, Class::MOP::_definition_context(), )); sub apply { my ( $self, $role, $object, $args ) = @_; my $obj_meta = Class::MOP::class_of($object) || 'Moose::Meta::Class'; # This is a special case to handle the case where the object's metaclass # is a Class::MOP::Class, but _not_ a Moose::Meta::Class (for example, # when applying a role to a Moose::Meta::Attribute object). $obj_meta = 'Moose::Meta::Class' unless $obj_meta->isa('Moose::Meta::Class'); my $class = $obj_meta->create_anon_class( superclasses => [ blessed($object) ], roles => [ $role, keys(%$args) ? ($args) : () ], cache => (all { $_ eq '-alias' || $_ eq '-excludes' } keys %$args), ); $class->rebless_instance( $object, %{ $self->rebless_params } ); } 1; # ABSTRACT: Compose a role into an instance __END__ =pod =head1 NAME Moose::Meta::Role::Application::ToInstance - Compose a role into an instance =head1 VERSION version 2.1005 =head1 DESCRIPTION =head2 METHODS =over 4 =item B =item B =item B =item B =back =head1 BUGS See L for details on reporting bugs. =head1 AUTHOR Moose is maintained by the Moose Cabal, along with the help of many contributors. See L and L for details. =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2013 by Infinity Interactive, Inc.. This is free software; you can redistribute it and/or modify it under the same terms as the Perl 5 programming language system itself. =cut attribute_inherited_slot_specs.t100644000767000024 2362712200352345 23501 0ustar00etherstaff000000000000Moose-2.1005/t/attributes#!/usr/bin/perl use strict; use warnings; use Test::More; use Test::Fatal; { package Thing::Meta::Attribute; use Moose; extends 'Moose::Meta::Attribute'; around illegal_options_for_inheritance => sub { return (shift->(@_), qw/trigger/); }; package Thing; use Moose; sub hello { 'Hello World (from Thing)' } sub goodbye { 'Goodbye World (from Thing)' } package Foo; use Moose; use Moose::Util::TypeConstraints; subtype 'FooStr' => as 'Str' => where { /Foo/ }; coerce 'FooStr' => from ArrayRef => via { 'FooArrayRef' }; has 'bar' => (is => 'ro', isa => 'Str', default => 'Foo::bar'); has 'baz' => (is => 'rw', isa => 'Ref'); has 'foo' => (is => 'rw', isa => 'FooStr'); has 'gorch' => (is => 'ro'); has 'gloum' => (is => 'ro', default => sub {[]}); has 'fleem' => (is => 'ro'); has 'bling' => (is => 'ro', isa => 'Thing'); has 'blang' => (is => 'ro', isa => 'Thing', handles => ['goodbye']); has 'bunch_of_stuff' => (is => 'rw', isa => 'ArrayRef'); has 'one_last_one' => (is => 'rw', isa => 'Ref'); # this one will work here .... has 'fail' => (isa => 'CodeRef', is => 'bare'); has 'other_fail' => (metaclass => 'Thing::Meta::Attribute', is => 'bare', trigger => sub { }); package Bar; use Moose; use Moose::Util::TypeConstraints; extends 'Foo'; ::is( ::exception { has '+bar' => (default => 'Bar::bar'); }, undef, '... we can change the default attribute option' ); ::is( ::exception { has '+baz' => (isa => 'ArrayRef'); }, undef, '... we can add change the isa as long as it is a subtype' ); ::is( ::exception { has '+foo' => (coerce => 1); }, undef, '... we can change/add coerce as an attribute option' ); ::is( ::exception { has '+gorch' => (required => 1); }, undef, '... we can change/add required as an attribute option' ); ::is( ::exception { has '+gloum' => (lazy => 1); }, undef, '... we can change/add lazy as an attribute option' ); ::is( ::exception { has '+fleem' => (lazy_build => 1); }, undef, '... we can add lazy_build as an attribute option' ); ::is( ::exception { has '+bunch_of_stuff' => (isa => 'ArrayRef[Int]'); }, undef, '... extend an attribute with parameterized type' ); ::is( ::exception { has '+one_last_one' => (isa => subtype('Ref', where { blessed $_ eq 'CODE' })); }, undef, '... extend an attribute with anon-subtype' ); ::is( ::exception { has '+one_last_one' => (isa => 'Value'); }, undef, '... now can extend an attribute with a non-subtype' ); ::is( ::exception { has '+fleem' => (weak_ref => 1); }, undef, '... now allowed to add the weak_ref option via inheritance' ); ::is( ::exception { has '+bling' => (handles => ['hello']); }, undef, '... we can add the handles attribute option' ); # this one will *not* work here .... ::isnt( ::exception { has '+blang' => (handles => ['hello']); }, undef, '... we can not alter the handles attribute option' ); ::is( ::exception { has '+fail' => (isa => 'Ref'); }, undef, '... can now create an attribute with an improper subtype relation' ); ::isnt( ::exception { has '+other_fail' => (trigger => sub {}); }, undef, '... cannot create an attribute with an illegal option' ); ::like( ::exception { has '+does_not_exist' => (isa => 'Str'); }, qr/in Bar/, '... cannot extend a non-existing attribute' ); } my $foo = Foo->new; isa_ok($foo, 'Foo'); is($foo->foo, undef, '... got the right undef default value'); is( exception { $foo->foo('FooString') }, undef, '... assigned foo correctly' ); is($foo->foo, 'FooString', '... got the right value for foo'); isnt( exception { $foo->foo([]) }, undef, '... foo is not coercing (as expected)' ); is($foo->bar, 'Foo::bar', '... got the right default value'); isnt( exception { $foo->bar(10) }, undef, '... Foo::bar is a read/only attr' ); is($foo->baz, undef, '... got the right undef default value'); { my $hash_ref = {}; is( exception { $foo->baz($hash_ref) }, undef, '... Foo::baz accepts hash refs' ); is($foo->baz, $hash_ref, '... got the right value assigned to baz'); my $array_ref = []; is( exception { $foo->baz($array_ref) }, undef, '... Foo::baz accepts an array ref' ); is($foo->baz, $array_ref, '... got the right value assigned to baz'); my $scalar_ref = \(my $var); is( exception { $foo->baz($scalar_ref) }, undef, '... Foo::baz accepts scalar ref' ); is($foo->baz, $scalar_ref, '... got the right value assigned to baz'); is( exception { $foo->bunch_of_stuff([qw[one two three]]) }, undef, '... Foo::bunch_of_stuff accepts an array of strings' ); is( exception { $foo->one_last_one(sub { 'Hello World'}) }, undef, '... Foo::one_last_one accepts a code ref' ); my $code_ref = sub { 1 }; is( exception { $foo->baz($code_ref) }, undef, '... Foo::baz accepts a code ref' ); is($foo->baz, $code_ref, '... got the right value assigned to baz'); } isnt( exception { Bar->new; }, undef, '... cannot create Bar without required gorch param' ); my $bar = Bar->new(gorch => 'Bar::gorch'); isa_ok($bar, 'Bar'); isa_ok($bar, 'Foo'); is($bar->foo, undef, '... got the right undef default value'); is( exception { $bar->foo('FooString') }, undef, '... assigned foo correctly' ); is($bar->foo, 'FooString', '... got the right value for foo'); is( exception { $bar->foo([]) }, undef, '... assigned foo correctly' ); is($bar->foo, 'FooArrayRef', '... got the right value for foo'); is($bar->gorch, 'Bar::gorch', '... got the right default value'); is($bar->bar, 'Bar::bar', '... got the right default value'); isnt( exception { $bar->bar(10) }, undef, '... Bar::bar is a read/only attr' ); is($bar->baz, undef, '... got the right undef default value'); { my $hash_ref = {}; isnt( exception { $bar->baz($hash_ref) }, undef, '... Bar::baz does not accept hash refs' ); my $array_ref = []; is( exception { $bar->baz($array_ref) }, undef, '... Bar::baz can accept an array ref' ); is($bar->baz, $array_ref, '... got the right value assigned to baz'); my $scalar_ref = \(my $var); isnt( exception { $bar->baz($scalar_ref) }, undef, '... Bar::baz does not accept a scalar ref' ); is( exception { $bar->bunch_of_stuff([1, 2, 3]) }, undef, '... Bar::bunch_of_stuff accepts an array of ints' ); isnt( exception { $bar->bunch_of_stuff([qw[one two three]]) }, undef, '... Bar::bunch_of_stuff does not accept an array of strings' ); my $code_ref = sub { 1 }; isnt( exception { $bar->baz($code_ref) }, undef, '... Bar::baz does not accept a code ref' ); } # check some meta-stuff ok(Bar->meta->has_attribute('foo'), '... Bar has a foo attr'); ok(Bar->meta->has_attribute('bar'), '... Bar has a bar attr'); ok(Bar->meta->has_attribute('baz'), '... Bar has a baz attr'); ok(Bar->meta->has_attribute('gorch'), '... Bar has a gorch attr'); ok(Bar->meta->has_attribute('gloum'), '... Bar has a gloum attr'); ok(Bar->meta->has_attribute('bling'), '... Bar has a bling attr'); ok(Bar->meta->has_attribute('bunch_of_stuff'), '... Bar does have a bunch_of_stuff attr'); ok(!Bar->meta->has_attribute('blang'), '... Bar has a blang attr'); ok(Bar->meta->has_attribute('fail'), '... Bar has a fail attr'); ok(!Bar->meta->has_attribute('other_fail'), '... Bar does not have an other_fail attr'); isnt(Foo->meta->get_attribute('foo'), Bar->meta->get_attribute('foo'), '... Foo and Bar have different copies of foo'); isnt(Foo->meta->get_attribute('bar'), Bar->meta->get_attribute('bar'), '... Foo and Bar have different copies of bar'); isnt(Foo->meta->get_attribute('baz'), Bar->meta->get_attribute('baz'), '... Foo and Bar have different copies of baz'); isnt(Foo->meta->get_attribute('gorch'), Bar->meta->get_attribute('gorch'), '... Foo and Bar have different copies of gorch'); isnt(Foo->meta->get_attribute('gloum'), Bar->meta->get_attribute('gloum'), '... Foo and Bar have different copies of gloum'); isnt(Foo->meta->get_attribute('bling'), Bar->meta->get_attribute('bling'), '... Foo and Bar have different copies of bling'); isnt(Foo->meta->get_attribute('bunch_of_stuff'), Bar->meta->get_attribute('bunch_of_stuff'), '... Foo and Bar have different copies of bunch_of_stuff'); ok(Bar->meta->get_attribute('bar')->has_type_constraint, '... Bar::bar inherited the type constraint too'); ok(Bar->meta->get_attribute('baz')->has_type_constraint, '... Bar::baz inherited the type constraint too'); is(Bar->meta->get_attribute('bar')->type_constraint->name, 'Str', '... Bar::bar inherited the right type constraint too'); is(Foo->meta->get_attribute('baz')->type_constraint->name, 'Ref', '... Foo::baz inherited the right type constraint too'); is(Bar->meta->get_attribute('baz')->type_constraint->name, 'ArrayRef', '... Bar::baz inherited the right type constraint too'); ok(!Foo->meta->get_attribute('gorch')->is_required, '... Foo::gorch is not a required attr'); ok(Bar->meta->get_attribute('gorch')->is_required, '... Bar::gorch is a required attr'); is(Foo->meta->get_attribute('bunch_of_stuff')->type_constraint->name, 'ArrayRef', '... Foo::bunch_of_stuff is an ArrayRef'); is(Bar->meta->get_attribute('bunch_of_stuff')->type_constraint->name, 'ArrayRef[Int]', '... Bar::bunch_of_stuff is an ArrayRef[Int]'); ok(!Foo->meta->get_attribute('gloum')->is_lazy, '... Foo::gloum is not a required attr'); ok(Bar->meta->get_attribute('gloum')->is_lazy, '... Bar::gloum is a required attr'); ok(!Foo->meta->get_attribute('foo')->should_coerce, '... Foo::foo should not coerce'); ok(Bar->meta->get_attribute('foo')->should_coerce, '... Bar::foo should coerce'); ok(!Foo->meta->get_attribute('bling')->has_handles, '... Foo::foo should not handles'); ok(Bar->meta->get_attribute('bling')->has_handles, '... Bar::foo should handles'); done_testing; attribute_traits_parameterized.t100644000767000024 254512200352345 23466 0ustar00etherstaff000000000000Moose-2.1005/t/attributes#!/usr/bin/env perl use strict; use warnings; use Test::More; { package My::Attribute::Trait; use Moose::Role; sub reversed_name { my $self = shift; scalar reverse $self->name; } } { package My::Class; use Moose; has foo => ( traits => [ 'My::Attribute::Trait' => { -alias => { reversed_name => 'eman', }, }, ], is => 'bare', ); } { package My::Other::Class; use Moose; has foo => ( traits => [ 'My::Attribute::Trait' => { -alias => { reversed_name => 'reversed', }, -excludes => 'reversed_name', }, ], is => 'bare', ); } my $attr = My::Class->meta->get_attribute('foo'); is($attr->eman, 'oof', 'the aliased method is in the attribute'); ok(!$attr->can('reversed'), "the method was not installed under the other class' alias"); my $other_attr = My::Other::Class->meta->get_attribute('foo'); is($other_attr->reversed, 'oof', 'the aliased method is in the attribute'); ok(!$other_attr->can('enam'), "the method was not installed under the other class' alias"); ok(!$other_attr->can('reversed_name'), "the method was not installed under the original name when that was excluded"); done_testing; immutable_metaclass_with_traits.t100644000767000024 233612200352345 23404 0ustar00etherstaff000000000000Moose-2.1005/t/immutable#!/usr/bin/env perl use strict; use warnings; use Test::More; { package FooTrait; use Moose::Role; } { package Foo; use Moose -traits => ['FooTrait']; } is(Class::MOP::class_of('Foo'), Foo->meta, "class_of and ->meta are the same on Foo"); my $meta = Foo->meta; is(Class::MOP::class_of($meta), $meta->meta, "class_of and ->meta are the same on Foo's metaclass"); isa_ok(Class::MOP::class_of($meta), 'Moose::Meta::Class'); isa_ok($meta->meta, 'Moose::Meta::Class'); ok($meta->is_mutable, "class is mutable"); ok(Class::MOP::class_of($meta)->is_mutable, "metaclass is mutable"); ok($meta->meta->does_role('FooTrait'), "does the trait"); Foo->meta->make_immutable; is(Class::MOP::class_of('Foo'), Foo->meta, "class_of and ->meta are the same on Foo (immutable)"); $meta = Foo->meta; isa_ok($meta->meta, 'Moose::Meta::Class'); ok($meta->is_immutable, "class is immutable"); ok($meta->meta->is_immutable, "metaclass is immutable (immutable class)"); is(Class::MOP::class_of($meta), $meta->meta, "class_of and ->meta are the same on Foo's metaclass (immutable)"); isa_ok(Class::MOP::class_of($meta), 'Moose::Meta::Class'); ok($meta->meta->does_role('FooTrait'), "still does the trait after immutable"); done_testing; role_composition_conflict_detection.t100644000767000024 165512200352345 23423 0ustar00etherstaff000000000000Moose-2.1005/t/rolesuse strict; use warnings; use Test::More; use Test::Fatal; use Moose::Util qw( find_meta ); { package RoleA; use Moose::Role; sub foo { 42 } } { package RoleB; use Moose::Role; with 'RoleA'; } { package RoleC; use Moose::Role; sub foo { 84 } } { my $composite = Moose::Meta::Role->combine( map { [ find_meta($_) => {} ] } qw( RoleA RoleB RoleC ) ); ok( $composite->requires_method('foo'), 'Composite of [ABC] requires a foo method' ); ok( ! $composite->has_method('foo'), 'Composite of [ABC] does not also have a foo method' ); } { my $composite = Moose::Meta::Role->combine( map { [ find_meta($_) => {} ] } qw( RoleA RoleC RoleB ) ); ok( $composite->requires_method('foo'), 'Composite of [ACB] requires a foo method' ); ok( ! $composite->has_method('foo'), 'Composite of [ACB] does not also have a foo method' ); } done_testing; define_type_twice_throws.t100644000767000024 72312200352345 23453 0ustar00etherstaff000000000000Moose-2.1005/t/type_constraints#!/usr/bin/perl use strict; use warnings; use Test::More; use Test::Fatal; use Moose::Util::TypeConstraints; { package Some::Class; use Moose::Util::TypeConstraints; subtype 'MySubType' => as 'Int' => where { 1 }; } like( exception { package Some::Other::Class; use Moose::Util::TypeConstraints; subtype 'MySubType' => as 'Int' => where { 1 }; }, qr/cannot be created again/, 'Trying to create same type twice throws' ); done_testing; extending_debugging_baseclassrole.t100644000767000024 140312200352345 23317 0ustar00etherstaff000000000000Moose-2.1005/t/recipes#!/usr/bin/perl -w use strict; use Test::More 'no_plan'; use Test::Fatal; $| = 1; # =begin testing SETUP use Test::Requires { 'Test::Output' => '0', }; # =begin testing SETUP { package MooseX::Debugging; use Moose::Exporter; Moose::Exporter->setup_import_methods( base_class_roles => ['MooseX::Debugging::Role::Object'], ); package MooseX::Debugging::Role::Object; use Moose::Role; sub BUILD {} after BUILD => sub { my $self = shift; warn "Made a new " . ( ref $self ) . " object\n"; }; } # =begin testing { { package Debugged; use Moose; MooseX::Debugging->import; } stderr_is( sub { Debugged->new }, "Made a new Debugged object\n", 'got expected output from debugging role' ); } 1; Company_Subtypes.pod100644000767000024 4174612200352345 23203 0ustar00etherstaff000000000000Moose-2.1005/lib/Moose/Cookbook/Basicspackage Moose::Cookbook::Basics::Company_Subtypes; # ABSTRACT: Demonstrates the use of subtypes and how to model classes related to companies, people, employees, etc. __END__ =pod =head1 NAME Moose::Cookbook::Basics::Company_Subtypes - Demonstrates the use of subtypes and how to model classes related to companies, people, employees, etc. =head1 VERSION version 2.1005 =head1 SYNOPSIS package Address; use Moose; use Moose::Util::TypeConstraints; use Locale::US; use Regexp::Common 'zip'; my $STATES = Locale::US->new; subtype 'USState' => as Str => where { ( exists $STATES->{code2state}{ uc($_) } || exists $STATES->{state2code}{ uc($_) } ); }; subtype 'USZipCode' => as Value => where { /^$RE{zip}{US}{-extended => 'allow'}$/; }; has 'street' => ( is => 'rw', isa => 'Str' ); has 'city' => ( is => 'rw', isa => 'Str' ); has 'state' => ( is => 'rw', isa => 'USState' ); has 'zip_code' => ( is => 'rw', isa => 'USZipCode' ); package Company; use Moose; use Moose::Util::TypeConstraints; has 'name' => ( is => 'rw', isa => 'Str', required => 1 ); has 'address' => ( is => 'rw', isa => 'Address' ); has 'employees' => ( is => 'rw', isa => 'ArrayRef[Employee]', default => sub { [] }, ); sub BUILD { my ( $self, $params ) = @_; foreach my $employee ( @{ $self->employees } ) { $employee->employer($self); } } after 'employees' => sub { my ( $self, $employees ) = @_; return unless $employees; foreach my $employee ( @$employees ) { $employee->employer($self); } }; package Person; use Moose; has 'first_name' => ( is => 'rw', isa => 'Str', required => 1 ); has 'last_name' => ( is => 'rw', isa => 'Str', required => 1 ); has 'middle_initial' => ( is => 'rw', isa => 'Str', predicate => 'has_middle_initial' ); has 'address' => ( is => 'rw', isa => 'Address' ); sub full_name { my $self = shift; return $self->first_name . ( $self->has_middle_initial ? ' ' . $self->middle_initial . '. ' : ' ' ) . $self->last_name; } package Employee; use Moose; extends 'Person'; has 'title' => ( is => 'rw', isa => 'Str', required => 1 ); has 'employer' => ( is => 'rw', isa => 'Company', weak_ref => 1 ); override 'full_name' => sub { my $self = shift; super() . ', ' . $self->title; }; =head1 DESCRIPTION This recipe introduces the C sugar function from L. The C function lets you declaratively create type constraints without building an entire class. In the recipe we also make use of L and L to build constraints, showing how constraints can make use of existing CPAN tools for data validation. Finally, we introduce the C attribute option. In the C
class we define two subtypes. The first uses the L module to check the validity of a state. It accepts either a state abbreviation of full name. A state will be passed in as a string, so we make our C type a subtype of Moose's builtin C type. This is done using the C sugar. The actual constraint is defined using C. This function accepts a single subroutine reference. That subroutine will be called with the value to be checked in C<$_> (1). It is expected to return a true or false value indicating whether the value is valid for the type. We can now use the C type just like Moose's builtin types: has 'state' => ( is => 'rw', isa => 'USState' ); When the C attribute is set, the value is checked against the C constraint. If the value is not valid, an exception will be thrown. The next C, C, uses L. L includes a regex for validating US zip codes. We use this constraint for the C attribute. subtype 'USZipCode' => as Value => where { /^$RE{zip}{US}{-extended => 'allow'}$/; }; Using a subtype instead of requiring a class for each type greatly simplifies the code. We don't really need a class for these types, as they're just strings, but we do want to ensure that they're valid. The type constraints we created are reusable. Type constraints are stored by name in a global registry, which means that we can refer to them in other classes. Because the registry is global, we do recommend that you use some sort of namespacing in real applications, like C (just as you would do with class names). These two subtypes allow us to define a simple C
class. Then we define our C class, which has an address. As we saw in earlier recipes, Moose automatically creates a type constraint for each our classes, so we can use that for the C class's C
attribute: has 'address' => ( is => 'rw', isa => 'Address' ); A company also needs a name: has 'name' => ( is => 'rw', isa => 'Str', required => 1 ); This introduces a new attribute option, C. If an attribute is required, then it must be passed to the class's constructor, or an exception will be thrown. It's important to understand that a C attribute can still be false or C, if its type constraint allows that. The next attribute, C, uses a I type constraint: has 'employees' => ( is => 'rw', isa => 'ArrayRef[Employee]' default => sub { [] }, ); This constraint says that C must be an array reference where each element of the array is an C object. It's worth noting that an I array reference also satisfies this constraint, such as the value given as the default here. Parameterizable type constraints (or "container types"), such as C, can be made more specific with a type parameter. In fact, we can arbitrarily nest these types, producing something like C. However, you can also just use the type by itself, so C is legal. (2) If you jump down to the definition of the C class, you will see that it has an C attribute. When we set the C for a C we want to make sure that each of these employee objects refers back to the right C in its C attribute. To do that, we need to hook into object construction. Moose lets us do this by writing a C method in our class. When your class defines a C method, it will be called by the constructor immediately after object construction, but before the object is returned to the caller. Note that all C methods in your class hierarchy will be called automatically; there is no need to (and you should not) call the superclass C method. The C class uses the C method to ensure that each employee of a company has the proper C object in its C attribute: sub BUILD { my ( $self, $params ) = @_; foreach my $employee ( @{ $self->employees } ) { $employee->employer($self); } } The C method is executed after type constraints are checked, so it is safe to assume that if C<< $self->employees >> has a value, it will be an array reference, and that the elements of that array reference will be C objects. We also want to make sure that whenever the C attribute for a C is changed, we also update the C for each employee. To do this we can use an C modifier: after 'employees' => sub { my ( $self, $employees ) = @_; return unless $employees; foreach my $employee ( @$employees ) { $employee->employer($self); } }; Again, as with the C method, we know that the type constraint check has already happened, so we know that if C<$employees> is defined it will contain an array reference of C objects. Note that C is a read/write accessor, so we must return early if it's called as a reader. The B class does not really demonstrate anything new. It has several C attributes. It also has a C method, which we first used in L. The only new feature in the C class is the C method modifier: override 'full_name' => sub { my $self = shift; super() . ', ' . $self->title; }; This is just a sugary alternative to Perl's built in C feature. However, there is one difference. You cannot pass any arguments to C. Instead, Moose simply passes the same parameters that were passed to the method. A more detailed example of usage can be found in F. =for testing-SETUP use Test::Requires { 'Locale::US' => '0', 'Regexp::Common' => '0', }; =head1 CONCLUSION This recipe was intentionally longer and more complex. It illustrates how Moose classes can be used together with type constraints, as well as the density of information that you can get out of a small amount of typing when using Moose. This recipe also introduced the C function, the C attribute, and the C method modifier. We will revisit type constraints in future recipes, and cover type coercion as well. =head1 FOOTNOTES =over 4 =item (1) The value being checked is also passed as the first argument to the C block, so it can be accessed as C<$_[0]>. =item (2) Note that C will not work. Moose will not parse this as a container type, and instead you will have a new type named "ArrayRef[]", which doesn't make any sense. =back =begin testing { package Company; sub get_employee_count { scalar @{(shift)->employees} } } use Scalar::Util 'isweak'; my $ii; is( exception { $ii = Company->new( { name => 'Infinity Interactive', address => Address->new( street => '565 Plandome Rd., Suite 307', city => 'Manhasset', state => 'NY', zip_code => '11030' ), employees => [ Employee->new( first_name => 'Jeremy', last_name => 'Shao', title => 'President / Senior Consultant', address => Address->new( city => 'Manhasset', state => 'NY' ) ), Employee->new( first_name => 'Tommy', last_name => 'Lee', title => 'Vice President / Senior Developer', address => Address->new( city => 'New York', state => 'NY' ) ), Employee->new( first_name => 'Stevan', middle_initial => 'C', last_name => 'Little', title => 'Senior Developer', address => Address->new( city => 'Madison', state => 'CT' ) ), ] } ); }, undef, '... created the entire company successfully' ); isa_ok( $ii, 'Company' ); is( $ii->name, 'Infinity Interactive', '... got the right name for the company' ); isa_ok( $ii->address, 'Address' ); is( $ii->address->street, '565 Plandome Rd., Suite 307', '... got the right street address' ); is( $ii->address->city, 'Manhasset', '... got the right city' ); is( $ii->address->state, 'NY', '... got the right state' ); is( $ii->address->zip_code, 11030, '... got the zip code' ); is( $ii->get_employee_count, 3, '... got the right employee count' ); # employee #1 isa_ok( $ii->employees->[0], 'Employee' ); isa_ok( $ii->employees->[0], 'Person' ); is( $ii->employees->[0]->first_name, 'Jeremy', '... got the right first name' ); is( $ii->employees->[0]->last_name, 'Shao', '... got the right last name' ); ok( !$ii->employees->[0]->has_middle_initial, '... no middle initial' ); is( $ii->employees->[0]->middle_initial, undef, '... got the right middle initial value' ); is( $ii->employees->[0]->full_name, 'Jeremy Shao, President / Senior Consultant', '... got the right full name' ); is( $ii->employees->[0]->title, 'President / Senior Consultant', '... got the right title' ); is( $ii->employees->[0]->employer, $ii, '... got the right company' ); ok( isweak( $ii->employees->[0]->{employer} ), '... the company is a weak-ref' ); isa_ok( $ii->employees->[0]->address, 'Address' ); is( $ii->employees->[0]->address->city, 'Manhasset', '... got the right city' ); is( $ii->employees->[0]->address->state, 'NY', '... got the right state' ); # employee #2 isa_ok( $ii->employees->[1], 'Employee' ); isa_ok( $ii->employees->[1], 'Person' ); is( $ii->employees->[1]->first_name, 'Tommy', '... got the right first name' ); is( $ii->employees->[1]->last_name, 'Lee', '... got the right last name' ); ok( !$ii->employees->[1]->has_middle_initial, '... no middle initial' ); is( $ii->employees->[1]->middle_initial, undef, '... got the right middle initial value' ); is( $ii->employees->[1]->full_name, 'Tommy Lee, Vice President / Senior Developer', '... got the right full name' ); is( $ii->employees->[1]->title, 'Vice President / Senior Developer', '... got the right title' ); is( $ii->employees->[1]->employer, $ii, '... got the right company' ); ok( isweak( $ii->employees->[1]->{employer} ), '... the company is a weak-ref' ); isa_ok( $ii->employees->[1]->address, 'Address' ); is( $ii->employees->[1]->address->city, 'New York', '... got the right city' ); is( $ii->employees->[1]->address->state, 'NY', '... got the right state' ); # employee #3 isa_ok( $ii->employees->[2], 'Employee' ); isa_ok( $ii->employees->[2], 'Person' ); is( $ii->employees->[2]->first_name, 'Stevan', '... got the right first name' ); is( $ii->employees->[2]->last_name, 'Little', '... got the right last name' ); ok( $ii->employees->[2]->has_middle_initial, '... got middle initial' ); is( $ii->employees->[2]->middle_initial, 'C', '... got the right middle initial value' ); is( $ii->employees->[2]->full_name, 'Stevan C. Little, Senior Developer', '... got the right full name' ); is( $ii->employees->[2]->title, 'Senior Developer', '... got the right title' ); is( $ii->employees->[2]->employer, $ii, '... got the right company' ); ok( isweak( $ii->employees->[2]->{employer} ), '... the company is a weak-ref' ); isa_ok( $ii->employees->[2]->address, 'Address' ); is( $ii->employees->[2]->address->city, 'Madison', '... got the right city' ); is( $ii->employees->[2]->address->state, 'CT', '... got the right state' ); # create new company my $new_company = Company->new( name => 'Infinity Interactive International' ); isa_ok( $new_company, 'Company' ); my $ii_employees = $ii->employees; foreach my $employee (@$ii_employees) { is( $employee->employer, $ii, '... has the ii company' ); } $new_company->employees($ii_employees); foreach my $employee ( @{ $new_company->employees } ) { is( $employee->employer, $new_company, '... has the different company now' ); } ## check some error conditions for the subtypes isnt( exception { Address->new( street => {} ),; }, undef, '... we die correctly with bad args' ); isnt( exception { Address->new( city => {} ),; }, undef, '... we die correctly with bad args' ); isnt( exception { Address->new( state => 'British Columbia' ),; }, undef, '... we die correctly with bad args' ); is( exception { Address->new( state => 'Connecticut' ),; }, undef, '... we live correctly with good args' ); isnt( exception { Address->new( zip_code => 'AF5J6$' ),; }, undef, '... we die correctly with bad args' ); is( exception { Address->new( zip_code => '06443' ),; }, undef, '... we live correctly with good args' ); isnt( exception { Company->new(),; }, undef, '... we die correctly without good args' ); is( exception { Company->new( name => 'Foo' ),; }, undef, '... we live correctly without good args' ); isnt( exception { Company->new( name => 'Foo', employees => [ Person->new ] ),; }, undef, '... we die correctly with good args' ); is( exception { Company->new( name => 'Foo', employees => [] ),; }, undef, '... we live correctly with good args' ); =end testing =head1 AUTHOR Moose is maintained by the Moose Cabal, along with the help of many contributors. See L and L for details. =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2013 by Infinity Interactive, Inc.. This is free software; you can redistribute it and/or modify it under the same terms as the Perl 5 programming language system itself. =cut Array.pm100644000767000024 2201112200352345 22757 0ustar00etherstaff000000000000Moose-2.1005/lib/Moose/Meta/Attribute/Native/Trait package Moose::Meta::Attribute::Native::Trait::Array; BEGIN { $Moose::Meta::Attribute::Native::Trait::Array::AUTHORITY = 'cpan:STEVAN'; } { $Moose::Meta::Attribute::Native::Trait::Array::VERSION = '2.1005'; } use Moose::Role; with 'Moose::Meta::Attribute::Native::Trait'; sub _helper_type { 'ArrayRef' } no Moose::Role; 1; # ABSTRACT: Helper trait for ArrayRef attributes __END__ =pod =head1 NAME Moose::Meta::Attribute::Native::Trait::Array - Helper trait for ArrayRef attributes =head1 VERSION version 2.1005 =head1 SYNOPSIS package Stuff; use Moose; has 'options' => ( traits => ['Array'], is => 'ro', isa => 'ArrayRef[Str]', default => sub { [] }, handles => { all_options => 'elements', add_option => 'push', map_options => 'map', filter_options => 'grep', find_option => 'first', get_option => 'get', join_options => 'join', count_options => 'count', has_options => 'count', has_no_options => 'is_empty', sorted_options => 'sort', }, ); no Moose; 1; =head1 DESCRIPTION This trait provides native delegation methods for array references. =head1 DEFAULT TYPE If you don't provide an C value for your attribute, it will default to C. =head1 PROVIDED METHODS =over 4 =item * B Returns the number of elements in the array. $stuff = Stuff->new; $stuff->options( [ "foo", "bar", "baz", "boo" ] ); print $stuff->count_options; # prints 4 This method does not accept any arguments. =item * B Returns a boolean value that is true when the array has no elements. $stuff->has_no_options ? die "No options!\n" : print "Good boy.\n"; This method does not accept any arguments. =item * B Returns all of the elements of the array as an array (not an array reference). my @option = $stuff->all_options; print "@options\n"; # prints "foo bar baz boo" This method does not accept any arguments. =item * B Returns an element of the array by its index. You can also use negative index numbers, just as with Perl's core array handling. my $option = $stuff->get_option(1); print "$option\n"; # prints "bar" If the specified element does not exist, this will return C. This method accepts just one argument. =item * B Just like Perl's builtin C. This method does not accept any arguments. =item * B Just like Perl's builtin C. Returns the number of elements in the new array. This method accepts any number of arguments. =item * B Just like Perl's builtin C. This method does not accept any arguments. =item * B Just like Perl's builtin C. Returns the number of elements in the new array. This method accepts any number of arguments. =item * B Just like Perl's builtin C. In scalar context, this returns the last element removed, or C if no elements were removed. In list context, this returns all the elements removed from the array. This method requires at least one argument. =item * B This method returns the first matching item in the array, just like L's C function. The matching is done with a subroutine reference you pass to this method. The subroutine will be called against each element in the array until one matches or all elements have been checked. my $found = $stuff->find_option( sub {/^b/} ); print "$found\n"; # prints "bar" This method requires a single argument. =item * B This method returns the index of the first matching item in the array, just like L's C function. The matching is done with a subroutine reference you pass to this method. The subroutine will be called against each element in the array until one matches or all elements have been checked. This method requires a single argument. =item * B This method returns every element matching a given criteria, just like Perl's core C function. This method requires a subroutine which implements the matching logic. my @found = $stuff->filter_options( sub {/^b/} ); print "@found\n"; # prints "bar baz boo" This method requires a single argument. =item * B This method transforms every element in the array and returns a new array, just like Perl's core C function. This method requires a subroutine which implements the transformation. my @mod_options = $stuff->map_options( sub { $_ . "-tag" } ); print "@mod_options\n"; # prints "foo-tag bar-tag baz-tag boo-tag" This method requires a single argument. =item * B This method turns an array into a single value, by passing a function the value so far and the next value in the array, just like L's C function. The reducing is done with a subroutine reference you pass to this method. my $found = $stuff->reduce_options( sub { $_[0] . $_[1] } ); print "$found\n"; # prints "foobarbazboo" This method requires a single argument. =item * B =item * B Returns the elements of the array in sorted order. You can provide an optional subroutine reference to sort with (as you can with Perl's core C function). However, instead of using C<$a> and C<$b> in this subroutine, you will need to use C<$_[0]> and C<$_[1]>. # ascending ASCIIbetical my @sorted = $stuff->sort_options(); # Descending alphabetical order my @sorted_options = $stuff->sort_options( sub { lc $_[1] cmp lc $_[0] } ); print "@sorted_options\n"; # prints "foo boo baz bar" This method accepts a single argument. =item * B =item * B Sorts the array I, modifying the value of the attribute. You can provide an optional subroutine reference to sort with (as you can with Perl's core C function). However, instead of using C<$a> and C<$b>, you will need to use C<$_[0]> and C<$_[1]> instead. This method does not define a return value. This method accepts a single argument. =item * B Returns the elements of the array in random order, like C from L. This method does not accept any arguments. =item * B Returns the array with all duplicate elements removed, like C from L. This method does not accept any arguments. =item * B Joins every element of the array using the separator given as argument, just like Perl's core C function. my $joined = $stuff->join_options(':'); print "$joined\n"; # prints "foo:bar:baz:boo" This method requires a single argument. =item * B Given an index and a value, sets the specified array element's value. This method returns the value at C<$index> after the set. This method requires two arguments. =item * B Removes the element at the given index from the array. This method returns the deleted value. Note that if no value exists, it will return C. This method requires one argument. =item * B Inserts a new element into the array at the given index. This method returns the new value at C<$index>. This method requires two arguments. =item * B Empties the entire array, like C<@array = ()>. This method does not define a return value. This method does not accept any arguments. =item * B =item * B This method provides a get/set accessor for the array, based on array indexes. If passed one argument, it returns the value at the specified index. If passed two arguments, it sets the value of the specified index. When called as a setter, this method returns the new value at C<$index>. This method accepts one or two arguments. =item * B =item * B This method returns an iterator which, on each call, returns C<$n> more items from the array, in order, like C from L. If you pass a coderef as the second argument, then this code ref will be called on each group of C<$n> elements in the array until the array is exhausted. This method accepts one or two arguments. =item * B This method returns a shallow clone of the array reference. The return value is a reference to a new array with the same elements. It is I because any elements that were references in the original will be the I references in the clone. =back =head1 BUGS See L for details on reporting bugs. =head1 AUTHOR Moose is maintained by the Moose Cabal, along with the help of many contributors. See L and L for details. =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2013 by Infinity Interactive, Inc.. This is free software; you can redistribute it and/or modify it under the same terms as the Perl 5 programming language system itself. =cut Array.pm100644000767000024 124712200352345 22703 0ustar00etherstaff000000000000Moose-2.1005/lib/Moose/Meta/Method/Accessor/Nativepackage Moose::Meta::Method::Accessor::Native::Array; BEGIN { $Moose::Meta::Method::Accessor::Native::Array::AUTHORITY = 'cpan:STEVAN'; } { $Moose::Meta::Method::Accessor::Native::Array::VERSION = '2.1005'; } use strict; use warnings; use Moose::Role; use Scalar::Util qw( looks_like_number ); sub _inline_check_var_is_valid_index { my $self = shift; my ($var) = @_; return ( 'if (!defined(' . $var . ') || ' . $var . ' !~ /^-?\d+$/) {', $self->_inline_throw_error( '"The index passed to ' . $self->delegate_to_method . ' must be an integer"', ) . ';', '}', ); } no Moose::Role; 1; Parameterized.pm100644000767000024 745612200352345 23207 0ustar00etherstaff000000000000Moose-2.1005/lib/Moose/Meta/TypeConstraintpackage Moose::Meta::TypeConstraint::Parameterized; BEGIN { $Moose::Meta::TypeConstraint::Parameterized::AUTHORITY = 'cpan:STEVAN'; } { $Moose::Meta::TypeConstraint::Parameterized::VERSION = '2.1005'; } use strict; use warnings; use metaclass; use Scalar::Util 'blessed'; use Moose::Util::TypeConstraints; use Moose::Meta::TypeConstraint::Parameterizable; use base 'Moose::Meta::TypeConstraint'; __PACKAGE__->meta->add_attribute('type_parameter' => ( accessor => 'type_parameter', predicate => 'has_type_parameter', Class::MOP::_definition_context(), )); __PACKAGE__->meta->add_attribute('parameterized_from' => ( accessor => 'parameterized_from', predicate => 'has_parameterized_from', Class::MOP::_definition_context(), )); sub equals { my ( $self, $type_or_name ) = @_; my $other = Moose::Util::TypeConstraints::find_type_constraint($type_or_name); return unless $other->isa(__PACKAGE__); return ( $self->type_parameter->equals( $other->type_parameter ) and $self->parent->equals( $other->parent ) ); } sub compile_type_constraint { my $self = shift; unless ( $self->has_type_parameter ) { require Moose; Moose->throw_error("You cannot create a Higher Order type without a type parameter"); } my $type_parameter = $self->type_parameter; unless ( blessed $type_parameter && $type_parameter->isa('Moose::Meta::TypeConstraint') ) { require Moose; Moose->throw_error("The type parameter must be a Moose meta type"); } foreach my $type (Moose::Util::TypeConstraints::get_all_parameterizable_types()) { if (my $constraint = $type->generate_constraint_for($self)) { $self->_set_constraint($constraint); return $self->SUPER::compile_type_constraint; } } # if we get here, then we couldn't # find a way to parameterize this type require Moose; Moose->throw_error("The " . $self->name . " constraint cannot be used, because " . $self->parent->name . " doesn't subtype or coerce from a parameterizable type."); } sub can_be_inlined { my $self = shift; return $self->has_parameterized_from && $self->parameterized_from->has_inline_generator && $self->type_parameter->can_be_inlined; } sub inline_environment { my $self = shift; return { ($self->has_parameterized_from ? (%{ $self->parameterized_from->inline_environment }) : ()), ($self->has_type_parameter ? (%{ $self->type_parameter->inline_environment }) : ()), }; } sub _inline_check { my $self = shift; return unless $self->can_be_inlined; return $self->parameterized_from->generate_inline_for( $self->type_parameter, @_ ); } sub create_child_type { my ($self, %opts) = @_; return Moose::Meta::TypeConstraint::Parameterizable->new(%opts, parent=>$self); } 1; # ABSTRACT: Type constraints with a bound parameter (ArrayRef[Int]) __END__ =pod =head1 NAME Moose::Meta::TypeConstraint::Parameterized - Type constraints with a bound parameter (ArrayRef[Int]) =head1 VERSION version 2.1005 =head1 METHODS This class is intentionally not documented because the API is confusing and needs some work. =head1 INHERITANCE C is a subclass of L. =head1 BUGS See L for details on reporting bugs. =head1 AUTHOR Moose is maintained by the Moose Cabal, along with the help of many contributors. See L and L for details. =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2013 by Infinity Interactive, Inc.. This is free software; you can redistribute it and/or modify it under the same terms as the Perl 5 programming language system itself. =cut illegal_options_for_inheritance.t100644000767000024 356112200352345 23563 0ustar00etherstaff000000000000Moose-2.1005/t/attributes#!/usr/bin/perl use strict; use warnings; use Test::More; use Test::Fatal; { package Foo; use Moose; has foo => ( is => 'ro', ); has bar => ( clearer => 'clear_bar', ); } { package Foo::Sub; use Moose; extends 'Foo'; ::is( ::exception { has '+foo' => (is => 'rw') }, undef, "can override is" ); ::like( ::exception { has '+foo' => (reader => 'bar') }, qr/illegal/, "can't override reader" ); ::is( ::exception { has '+foo' => (clearer => 'baz') }, undef, "can override unspecified things" ); ::like( ::exception { has '+bar' => (clearer => 'quux') }, qr/illegal/, "can't override clearer" ); ::is( ::exception { has '+bar' => (predicate => 'has_bar') }, undef, "can override unspecified things" ); } { package Bar::Meta::Attribute; use Moose::Role; has my_illegal_option => (is => 'ro'); around illegal_options_for_inheritance => sub { return (shift->(@_), 'my_illegal_option'); }; } { package Bar; use Moose; ::is( ::exception { has bar => ( traits => ['Bar::Meta::Attribute'], my_illegal_option => 'FOO', is => 'bare', ); }, undef, "can use illegal options" ); has baz => ( traits => ['Bar::Meta::Attribute'], is => 'bare', ); } { package Bar::Sub; use Moose; extends 'Bar'; ::like( ::exception { has '+bar' => (my_illegal_option => 'BAR') }, qr/illegal/, "can't override illegal attribute" ); ::is( ::exception { has '+baz' => (my_illegal_option => 'BAR') }, undef, "can add illegal option if superclass doesn't set it" ); } my $bar_attr = Bar->meta->get_attribute('bar'); ok((grep { $_ eq 'my_illegal_option' } $bar_attr->illegal_options_for_inheritance) > 0, '... added my_illegal_option as illegal option for inheritance'); done_testing; Trait000755000767000024 012200352345 21456 5ustar00etherstaff000000000000Moose-2.1005/t/lib/Moose/Meta/Attribute/CustomBar.pm100600000767000024 22612200352345 22630 0ustar00etherstaff000000000000Moose-2.1005/t/lib/Moose/Meta/Attribute/Custom/Traitpackage Moose::Meta::Attribute::Custom::Trait::Bar; sub register_implementation { 'My::Trait::Bar' } package My::Trait::Bar; use Moose::Role; 1; Foo.pm100600000767000024 11212200352345 22641 0ustar00etherstaff000000000000Moose-2.1005/t/lib/Moose/Meta/Attribute/Custom/Traitpackage Moose::Meta::Attribute::Custom::Trait::Foo; use Moose::Role; 1; create_anon_with_required_attr.t100644000767000024 421212200352345 23533 0ustar00etherstaff000000000000Moose-2.1005/t/metaclasses#!/usr/bin/perl # this functionality may be pushing toward parametric roles/classes # it's off in a corner and may not be that important use strict; use warnings; use Test::More; use Test::Fatal; { package HasFoo; use Moose::Role; has 'foo' => ( is => 'ro', isa => 'Str', required => 1, ); } { package My::Metaclass; use Moose; extends 'Moose::Meta::Class'; with 'HasFoo'; } package main; my $anon; is( exception { $anon = My::Metaclass->create_anon_class( foo => 'this' ); }, undef, 'create anon class with required attr' ); isa_ok( $anon, 'My::Metaclass' ); cmp_ok( $anon->foo, 'eq', 'this', 'foo is this' ); isnt( exception { $anon = My::Metaclass->create_anon_class(); }, undef, 'failed to create anon class without required attr' ); my $meta; is( exception { $meta = My::Metaclass->initialize( 'Class::Name1' => ( foo => 'that' ) ); }, undef, 'initialize a class with required attr' ); isa_ok( $meta, 'My::Metaclass' ); cmp_ok( $meta->foo, 'eq', 'that', 'foo is that' ); cmp_ok( $meta->name, 'eq', 'Class::Name1', 'for the correct class' ); isnt( exception { $meta = My::Metaclass->initialize( 'Class::Name2' ); }, undef, 'failed to initialize a class without required attr' ); is( exception { eval qq{ package Class::Name3; use metaclass 'My::Metaclass' => ( foo => 'another', ); use Moose; }; die $@ if $@; }, undef, 'use metaclass with required attr' ); $meta = Class::Name3->meta; isa_ok( $meta, 'My::Metaclass' ); cmp_ok( $meta->foo, 'eq', 'another', 'foo is another' ); cmp_ok( $meta->name, 'eq', 'Class::Name3', 'for the correct class' ); isnt( exception { eval qq{ package Class::Name4; use metaclass 'My::Metaclass'; use Moose; }; die $@ if $@; }, undef, 'failed to use metaclass without required attr' ); # how do we pass a required attribute to -traits? isnt( exception { eval qq{ package Class::Name5; use Moose -traits => 'HasFoo'; }; die $@ if $@; }, undef, 'failed to use trait without required attr' ); done_testing; immutable_metaclass_compat_bug.t100644000767000024 133612200352345 23507 0ustar00etherstaff000000000000Moose-2.1005/t/metaclasses#!/usr/bin/env perl use strict; use warnings; use Test::More; { package Foo::Base::Meta::Trait; use Moose::Role; } { package Foo::Base; use Moose; Moose::Util::MetaRole::apply_metaroles( for => __PACKAGE__, class_metaroles => { constructor => ['Foo::Base::Meta::Trait'] }, ); __PACKAGE__->meta->make_immutable; } { package Foo::Meta::Trait; use Moose::Role; } { package Foo; use Moose; Moose::Util::MetaRole::apply_metaroles( for => __PACKAGE__, class_metaroles => { constructor => ['Foo::Meta::Trait'] } ); ::ok(!Foo->meta->is_immutable); extends 'Foo::Base'; ::ok(!Foo->meta->is_immutable); } done_testing; metaclass_compat_no_fixing_bug.t100644000767000024 170112200352345 23504 0ustar00etherstaff000000000000Moose-2.1005/t/metaclasses#!/usr/bin/env perl use strict; use warnings; use Test::More; use Test::Fatal; { package Foo::Meta::Constructor1; use Moose::Role; } { package Foo::Meta::Constructor2; use Moose::Role; } { package Foo; use Moose; Moose::Util::MetaRole::apply_metaroles( for => __PACKAGE__, class_metaroles => { constructor => ['Foo::Meta::Constructor1'] }, ); } { package Foo::Sub; use Moose; Moose::Util::MetaRole::apply_metaroles( for => __PACKAGE__, class_metaroles => { constructor => ['Foo::Meta::Constructor2'] }, ); extends 'Foo'; } { package Foo::Sub::Sub; use Moose; Moose::Util::MetaRole::apply_metaroles( for => __PACKAGE__, class_metaroles => { constructor => ['Foo::Meta::Constructor2'] }, ); ::is( ::exception { extends 'Foo::Sub' }, undef, "doesn't try to fix if nothing is needed" ); } done_testing; metaclass_parameterized_traits.t100644000767000024 216312200352345 23551 0ustar00etherstaff000000000000Moose-2.1005/t/metaclasses#!/usr/bin/env perl use strict; use warnings; use Test::More; { package My::Trait; use Moose::Role; sub reversed_name { my $self = shift; scalar reverse $self->name; } } { package My::Class; use Moose -traits => [ 'My::Trait' => { -alias => { reversed_name => 'enam', }, }, ]; } { package My::Other::Class; use Moose -traits => [ 'My::Trait' => { -alias => { reversed_name => 'reversed', }, -excludes => 'reversed_name', }, ]; } my $meta = My::Class->meta; is($meta->enam, 'ssalC::yM', 'parameterized trait applied'); ok(!$meta->can('reversed'), "the method was not installed under the other class' alias"); my $other_meta = My::Other::Class->meta; is($other_meta->reversed, 'ssalC::rehtO::yM', 'parameterized trait applied'); ok(!$other_meta->can('enam'), "the method was not installed under the other class' alias"); ok(!$other_meta->can('reversed_name'), "the method was not installed under the original name when that was excluded"); done_testing; moose_util_search_class_by_role.t100644000767000024 235112200352345 23551 0ustar00etherstaff000000000000Moose-2.1005/t/moose_util#!/usr/bin/perl use strict; use warnings; use Test::More; use Moose::Util ':all'; { package SCBR::Role; use Moose::Role; } { package SCBR::A; use Moose; } is search_class_by_role('SCBR::A', 'SCBR::Role'), undef, '... not found role returns undef'; is search_class_by_role('SCBR::A', SCBR::Role->meta), undef, '... not found role returns undef'; { package SCBR::B; use Moose; extends 'SCBR::A'; with 'SCBR::Role'; } is search_class_by_role('SCBR::B', 'SCBR::Role'), 'SCBR::B', '... class itself returned if it does role'; is search_class_by_role('SCBR::B', SCBR::Role->meta), 'SCBR::B', '... class itself returned if it does role'; { package SCBR::C; use Moose; extends 'SCBR::B'; } is search_class_by_role('SCBR::C', 'SCBR::Role'), 'SCBR::B', '... nearest class doing role returned'; is search_class_by_role('SCBR::C', SCBR::Role->meta), 'SCBR::B', '... nearest class doing role returned'; { package SCBR::D; use Moose; extends 'SCBR::C'; with 'SCBR::Role'; } is search_class_by_role('SCBR::D', 'SCBR::Role'), 'SCBR::D', '... nearest class being direct class returned'; is search_class_by_role('SCBR::D', SCBR::Role->meta), 'SCBR::D', '... nearest class being direct class returned'; done_testing; container_type_constraint.t100644000767000024 550212200352345 23666 0ustar00etherstaff000000000000Moose-2.1005/t/type_constraints#!/usr/bin/perl use strict; use warnings; use Test::More; use Moose::Util::TypeConstraints; use Moose::Meta::TypeConstraint::Parameterized; # Array of Ints my $array_of_ints = Moose::Meta::TypeConstraint::Parameterized->new( name => 'ArrayRef[Int]', parent => find_type_constraint('ArrayRef'), type_parameter => find_type_constraint('Int'), ); isa_ok($array_of_ints, 'Moose::Meta::TypeConstraint::Parameterized'); isa_ok($array_of_ints, 'Moose::Meta::TypeConstraint'); ok($array_of_ints->check([ 1, 2, 3, 4 ]), '... [ 1, 2, 3, 4 ] passed successfully'); ok(!$array_of_ints->check([qw/foo bar baz/]), '... [qw/foo bar baz/] failed successfully'); ok(!$array_of_ints->check([ 1, 2, 3, qw/foo bar/]), '... [ 1, 2, 3, qw/foo bar/] failed successfully'); ok(!$array_of_ints->check(1), '... 1 failed successfully'); ok(!$array_of_ints->check({}), '... {} failed successfully'); ok(!$array_of_ints->check(sub { () }), '... sub { () } failed successfully'); # Hash of Ints my $hash_of_ints = Moose::Meta::TypeConstraint::Parameterized->new( name => 'HashRef[Int]', parent => find_type_constraint('HashRef'), type_parameter => find_type_constraint('Int'), ); isa_ok($hash_of_ints, 'Moose::Meta::TypeConstraint::Parameterized'); isa_ok($hash_of_ints, 'Moose::Meta::TypeConstraint'); ok($hash_of_ints->check({ one => 1, two => 2, three => 3 }), '... { one => 1, two => 2, three => 3 } passed successfully'); ok(!$hash_of_ints->check({ 1 => 'one', 2 => 'two', 3 => 'three' }), '... { 1 => one, 2 => two, 3 => three } failed successfully'); ok(!$hash_of_ints->check({ 1 => 'one', 2 => 'two', three => 3 }), '... { 1 => one, 2 => two, three => 3 } failed successfully'); ok(!$hash_of_ints->check(1), '... 1 failed successfully'); ok(!$hash_of_ints->check([]), '... [] failed successfully'); ok(!$hash_of_ints->check(sub { () }), '... sub { () } failed successfully'); # Array of Array of Ints my $array_of_array_of_ints = Moose::Meta::TypeConstraint::Parameterized->new( name => 'ArrayRef[ArrayRef[Int]]', parent => find_type_constraint('ArrayRef'), type_parameter => $array_of_ints, ); isa_ok($array_of_array_of_ints, 'Moose::Meta::TypeConstraint::Parameterized'); isa_ok($array_of_array_of_ints, 'Moose::Meta::TypeConstraint'); ok($array_of_array_of_ints->check( [[ 1, 2, 3 ], [ 4, 5, 6 ]] ), '... [[ 1, 2, 3 ], [ 4, 5, 6 ]] passed successfully'); ok(!$array_of_array_of_ints->check( [[ 1, 2, 3 ], [ qw/foo bar/ ]] ), '... [[ 1, 2, 3 ], [ qw/foo bar/ ]] failed successfully'); { my $anon_type = Moose::Util::TypeConstraints::find_or_parse_type_constraint('ArrayRef[Foo]'); isa_ok( $anon_type, 'Moose::Meta::TypeConstraint::Parameterized' ); my $param_type = $anon_type->type_parameter; isa_ok( $param_type, 'Moose::Meta::TypeConstraint::Class' ); } done_testing; union_types_and_coercions.t100644000767000024 1050112200352345 23654 0ustar00etherstaff000000000000Moose-2.1005/t/type_constraints#!/usr/bin/perl use strict; use warnings; use Test::More; use Test::Fatal; use Test::Requires { 'IO::String' => '0.01', # skip all if not installed 'IO::File' => '0.01', }; { package Email::Moose; use Moose; use Moose::Util::TypeConstraints; use IO::String; our $VERSION = '0.01'; # create subtype for IO::String subtype 'IO::String' => as 'Object' => where { $_->isa('IO::String') }; coerce 'IO::String' => from 'Str' => via { IO::String->new($_) }, => from 'ScalarRef', => via { IO::String->new($_) }; # create subtype for IO::File subtype 'IO::File' => as 'Object' => where { $_->isa('IO::File') }; coerce 'IO::File' => from 'FileHandle' => via { bless $_, 'IO::File' }; # create the alias subtype 'IO::StringOrFile' => as 'IO::String | IO::File'; # attributes has 'raw_body' => ( is => 'rw', isa => 'IO::StringOrFile', coerce => 1, default => sub { IO::String->new() }, ); sub as_string { my ($self) = @_; my $fh = $self->raw_body(); return do { local $/; <$fh> }; } } { my $email = Email::Moose->new; isa_ok($email, 'Email::Moose'); isa_ok($email->raw_body, 'IO::String'); is($email->as_string, undef, '... got correct empty string'); } { my $email = Email::Moose->new(raw_body => '... this is my body ...'); isa_ok($email, 'Email::Moose'); isa_ok($email->raw_body, 'IO::String'); is($email->as_string, '... this is my body ...', '... got correct string'); is( exception { $email->raw_body('... this is the next body ...'); }, undef, '... this will coerce correctly' ); isa_ok($email->raw_body, 'IO::String'); is($email->as_string, '... this is the next body ...', '... got correct string'); } { my $str = '... this is my body (ref) ...'; my $email = Email::Moose->new(raw_body => \$str); isa_ok($email, 'Email::Moose'); isa_ok($email->raw_body, 'IO::String'); is($email->as_string, $str, '... got correct string'); my $str2 = '... this is the next body (ref) ...'; is( exception { $email->raw_body(\$str2); }, undef, '... this will coerce correctly' ); isa_ok($email->raw_body, 'IO::String'); is($email->as_string, $str2, '... got correct string'); } { my $io_str = IO::String->new('... this is my body (IO::String) ...'); my $email = Email::Moose->new(raw_body => $io_str); isa_ok($email, 'Email::Moose'); isa_ok($email->raw_body, 'IO::String'); is($email->raw_body, $io_str, '... and it is the one we expected'); is($email->as_string, '... this is my body (IO::String) ...', '... got correct string'); my $io_str2 = IO::String->new('... this is the next body (IO::String) ...'); is( exception { $email->raw_body($io_str2); }, undef, '... this will coerce correctly' ); isa_ok($email->raw_body, 'IO::String'); is($email->raw_body, $io_str2, '... and it is the one we expected'); is($email->as_string, '... this is the next body (IO::String) ...', '... got correct string'); } { my $fh; open($fh, '<', $0) || die "Could not open $0"; my $email = Email::Moose->new(raw_body => $fh); isa_ok($email, 'Email::Moose'); isa_ok($email->raw_body, 'IO::File'); close($fh); } { my $fh = IO::File->new($0); my $email = Email::Moose->new(raw_body => $fh); isa_ok($email, 'Email::Moose'); isa_ok($email->raw_body, 'IO::File'); is($email->raw_body, $fh, '... and it is the one we expected'); } { package Foo; use Moose; use Moose::Util::TypeConstraints; subtype 'Coerced' => as 'ArrayRef'; coerce 'Coerced' => from 'Value' => via { [ $_ ] }; has carray => ( is => 'ro', isa => 'Coerced | Coerced', coerce => 1, ); } { my $foo; is( exception { $foo = Foo->new( carray => 1 ) }, undef, 'Can pass non-ref value for carray' ); is_deeply( $foo->carray, [1], 'carray was coerced to an array ref' ); like( exception { Foo->new( carray => {} ) }, qr/\QValidation failed for 'Coerced|Coerced' with value \E(?!undef)/, 'Cannot pass a hash ref for carray attribute, and hash ref is not coerced to an undef' ); } done_testing; util_find_type_constraint.t100644000767000024 117612200352345 23664 0ustar00etherstaff000000000000Moose-2.1005/t/type_constraints#!/usr/bin/perl use strict; use warnings; use Test::More; use Moose::Util::TypeConstraints; foreach my $type_name (qw( Any Item Bool Undef Defined Value Num Int Str Ref ScalarRef ArrayRef HashRef CodeRef RegexpRef Object )) { is(find_type_constraint($type_name)->name, $type_name, '... got the right name for ' . $type_name); } # TODO: # add tests for is_subtype_of which confirm the hierarchy done_testing; util_std_type_constraints.t100644000767000024 7011412200352345 23737 0ustar00etherstaff000000000000Moose-2.1005/t/type_constraints#!/usr/bin/perl use strict; use warnings; use Test::Fatal; use Test::More; use Eval::Closure; use IO::File; use Moose::Util::TypeConstraints; use Scalar::Util qw( blessed openhandle ); my $ZERO = 0; my $ONE = 1; my $INT = 100; my $NEG_INT = -100; my $NUM = 42.42; my $NEG_NUM = -42.42; my $EMPTY_STRING = q{}; my $STRING = 'foo'; my $NUM_IN_STRING = 'has 42 in it'; my $INT_WITH_NL1 = "1\n"; my $INT_WITH_NL2 = "\n1"; my $SCALAR_REF = \( my $var ); my $SCALAR_REF_REF = \$SCALAR_REF; my $ARRAY_REF = []; my $HASH_REF = {}; my $CODE_REF = sub { }; my $GLOB = do { no warnings 'once'; *GLOB_REF }; my $GLOB_REF = \$GLOB; open my $FH, '<', $0 or die "Could not open $0 for the test"; my $FH_OBJECT = IO::File->new( $0, 'r' ) or die "Could not open $0 for the test"; my $REGEX = qr/../; my $REGEX_OBJ = bless qr/../, 'BlessedQR'; my $FAKE_REGEX = bless {}, 'Regexp'; my $OBJECT = bless {}, 'Foo'; my $UNDEF = undef; { package Thing; sub foo { } } my $CLASS_NAME = 'Thing'; { package Role; use Moose::Role; sub foo { } } my $ROLE_NAME = 'Role'; my %tests = ( Any => { accept => [ $ZERO, $ONE, $INT, $NEG_INT, $NUM, $NEG_NUM, $EMPTY_STRING, $STRING, $NUM_IN_STRING, $INT_WITH_NL1, $INT_WITH_NL2, $SCALAR_REF, $SCALAR_REF_REF, $ARRAY_REF, $HASH_REF, $CODE_REF, $GLOB, $GLOB_REF, $FH, $FH_OBJECT, $REGEX, $REGEX_OBJ, $FAKE_REGEX, $OBJECT, $UNDEF, ], }, Item => { accept => [ $ZERO, $ONE, $INT, $NEG_INT, $NUM, $NEG_NUM, $EMPTY_STRING, $STRING, $NUM_IN_STRING, $INT_WITH_NL1, $INT_WITH_NL2, $SCALAR_REF, $SCALAR_REF_REF, $ARRAY_REF, $HASH_REF, $CODE_REF, $GLOB, $GLOB_REF, $FH, $FH_OBJECT, $REGEX, $REGEX_OBJ, $FAKE_REGEX, $OBJECT, $UNDEF, ], }, Defined => { accept => [ $ZERO, $ONE, $INT, $NEG_INT, $NUM, $NEG_NUM, $EMPTY_STRING, $STRING, $NUM_IN_STRING, $INT_WITH_NL1, $INT_WITH_NL2, $SCALAR_REF, $SCALAR_REF_REF, $ARRAY_REF, $HASH_REF, $CODE_REF, $GLOB, $GLOB_REF, $FH, $FH_OBJECT, $REGEX, $REGEX_OBJ, $FAKE_REGEX, $OBJECT, ], reject => [ $UNDEF, ], }, Undef => { accept => [ $UNDEF, ], reject => [ $ZERO, $ONE, $INT, $NEG_INT, $NUM, $NEG_NUM, $EMPTY_STRING, $STRING, $NUM_IN_STRING, $INT_WITH_NL1, $INT_WITH_NL2, $SCALAR_REF, $SCALAR_REF_REF, $ARRAY_REF, $HASH_REF, $CODE_REF, $GLOB, $GLOB_REF, $FH, $FH_OBJECT, $REGEX, $REGEX_OBJ, $FAKE_REGEX, $OBJECT, ], }, Bool => { accept => [ $ZERO, $ONE, $EMPTY_STRING, $UNDEF, ], reject => [ $INT, $NEG_INT, $NUM, $NEG_NUM, $STRING, $NUM_IN_STRING, $INT_WITH_NL1, $INT_WITH_NL2, $SCALAR_REF, $SCALAR_REF_REF, $ARRAY_REF, $HASH_REF, $CODE_REF, $GLOB, $GLOB_REF, $FH, $FH_OBJECT, $REGEX, $REGEX_OBJ, $FAKE_REGEX, $OBJECT, ], }, Maybe => { accept => [ $ZERO, $ONE, $INT, $NEG_INT, $NUM, $NEG_NUM, $EMPTY_STRING, $STRING, $NUM_IN_STRING, $INT_WITH_NL1, $INT_WITH_NL2, $SCALAR_REF, $SCALAR_REF_REF, $ARRAY_REF, $HASH_REF, $CODE_REF, $GLOB, $GLOB_REF, $FH, $FH_OBJECT, $REGEX, $REGEX_OBJ, $FAKE_REGEX, $OBJECT, $UNDEF, ], }, Value => { accept => [ $ZERO, $ONE, $INT, $NEG_INT, $NUM, $NEG_NUM, $EMPTY_STRING, $STRING, $NUM_IN_STRING, $INT_WITH_NL1, $INT_WITH_NL2, $GLOB, ], reject => [ $SCALAR_REF, $SCALAR_REF_REF, $ARRAY_REF, $HASH_REF, $CODE_REF, $GLOB_REF, $FH, $FH_OBJECT, $REGEX, $REGEX_OBJ, $FAKE_REGEX, $OBJECT, $UNDEF, ], }, Ref => { accept => [ $SCALAR_REF, $SCALAR_REF_REF, $ARRAY_REF, $HASH_REF, $CODE_REF, $GLOB_REF, $FH, $FH_OBJECT, $REGEX, $REGEX_OBJ, $FAKE_REGEX, $OBJECT, ], reject => [ $ZERO, $ONE, $INT, $NEG_INT, $NUM, $NEG_NUM, $EMPTY_STRING, $STRING, $NUM_IN_STRING, $INT_WITH_NL1, $INT_WITH_NL2, $GLOB, $UNDEF, ], }, Num => { accept => [ $ZERO, $ONE, $INT, $NEG_INT, $NUM, $NEG_NUM, ], reject => [ $EMPTY_STRING, $STRING, $NUM_IN_STRING, $SCALAR_REF, $SCALAR_REF_REF, $ARRAY_REF, $HASH_REF, $CODE_REF, $GLOB, $GLOB_REF, $FH, $FH_OBJECT, $REGEX, $REGEX_OBJ, $FAKE_REGEX, $OBJECT, $UNDEF, $INT_WITH_NL1, $INT_WITH_NL2, ], }, Int => { accept => [ $ZERO, $ONE, $INT, $NEG_INT, ], reject => [ $NUM, $NEG_NUM, $EMPTY_STRING, $STRING, $NUM_IN_STRING, $INT_WITH_NL1, $INT_WITH_NL2, $SCALAR_REF, $SCALAR_REF_REF, $ARRAY_REF, $HASH_REF, $CODE_REF, $GLOB, $GLOB_REF, $FH, $FH_OBJECT, $REGEX, $REGEX_OBJ, $FAKE_REGEX, $OBJECT, $UNDEF, ], }, Str => { accept => [ $ZERO, $ONE, $INT, $NEG_INT, $NUM, $NEG_NUM, $EMPTY_STRING, $STRING, $NUM_IN_STRING, $INT_WITH_NL1, $INT_WITH_NL2, ], reject => [ $SCALAR_REF, $SCALAR_REF_REF, $ARRAY_REF, $HASH_REF, $CODE_REF, $GLOB, $GLOB_REF, $FH, $FH_OBJECT, $REGEX, $REGEX_OBJ, $FAKE_REGEX, $OBJECT, $UNDEF, ], }, ScalarRef => { accept => [ $SCALAR_REF, $SCALAR_REF_REF, ], reject => [ $ZERO, $ONE, $INT, $NEG_INT, $NUM, $NEG_NUM, $EMPTY_STRING, $STRING, $NUM_IN_STRING, $INT_WITH_NL1, $INT_WITH_NL2, $ARRAY_REF, $HASH_REF, $CODE_REF, $GLOB, $GLOB_REF, $FH, $FH_OBJECT, $REGEX, $REGEX_OBJ, $FAKE_REGEX, $OBJECT, $UNDEF, ], }, ArrayRef => { accept => [ $ARRAY_REF, ], reject => [ $ZERO, $ONE, $INT, $NEG_INT, $NUM, $NEG_NUM, $EMPTY_STRING, $STRING, $NUM_IN_STRING, $INT_WITH_NL1, $INT_WITH_NL2, $SCALAR_REF, $SCALAR_REF_REF, $HASH_REF, $CODE_REF, $GLOB, $GLOB_REF, $FH, $FH_OBJECT, $REGEX, $REGEX_OBJ, $FAKE_REGEX, $OBJECT, $UNDEF, ], }, HashRef => { accept => [ $HASH_REF, ], reject => [ $ZERO, $ONE, $INT, $NEG_INT, $NUM, $NEG_NUM, $EMPTY_STRING, $STRING, $NUM_IN_STRING, $INT_WITH_NL1, $INT_WITH_NL2, $SCALAR_REF, $SCALAR_REF_REF, $ARRAY_REF, $CODE_REF, $GLOB, $GLOB_REF, $FH, $FH_OBJECT, $REGEX, $REGEX_OBJ, $FAKE_REGEX, $OBJECT, $UNDEF, ], }, CodeRef => { accept => [ $CODE_REF, ], reject => [ $ZERO, $ONE, $INT, $NEG_INT, $NUM, $NEG_NUM, $EMPTY_STRING, $STRING, $NUM_IN_STRING, $INT_WITH_NL1, $INT_WITH_NL2, $SCALAR_REF, $SCALAR_REF_REF, $ARRAY_REF, $HASH_REF, $GLOB, $GLOB_REF, $FH, $FH_OBJECT, $REGEX, $REGEX_OBJ, $FAKE_REGEX, $OBJECT, $UNDEF, ], }, RegexpRef => { accept => [ $REGEX, $REGEX_OBJ, ], reject => [ $ZERO, $ONE, $INT, $NEG_INT, $NUM, $NEG_NUM, $EMPTY_STRING, $STRING, $NUM_IN_STRING, $INT_WITH_NL1, $INT_WITH_NL2, $SCALAR_REF, $SCALAR_REF_REF, $ARRAY_REF, $HASH_REF, $CODE_REF, $GLOB, $GLOB_REF, $FH, $FH_OBJECT, $OBJECT, $UNDEF, $FAKE_REGEX, ], }, GlobRef => { accept => [ $GLOB_REF, $FH, ], reject => [ $ZERO, $ONE, $INT, $NEG_INT, $NUM, $NEG_NUM, $EMPTY_STRING, $STRING, $NUM_IN_STRING, $INT_WITH_NL1, $INT_WITH_NL2, $SCALAR_REF, $SCALAR_REF_REF, $ARRAY_REF, $HASH_REF, $CODE_REF, $GLOB, $FH_OBJECT, $OBJECT, $REGEX, $REGEX_OBJ, $FAKE_REGEX, $UNDEF, ], }, FileHandle => { accept => [ $FH, $FH_OBJECT, ], reject => [ $ZERO, $ONE, $INT, $NEG_INT, $NUM, $NEG_NUM, $EMPTY_STRING, $STRING, $NUM_IN_STRING, $INT_WITH_NL1, $INT_WITH_NL2, $SCALAR_REF, $SCALAR_REF_REF, $ARRAY_REF, $HASH_REF, $CODE_REF, $GLOB, $GLOB_REF, $OBJECT, $REGEX, $REGEX_OBJ, $FAKE_REGEX, $UNDEF, ], }, Object => { accept => [ $FH_OBJECT, $REGEX, $REGEX_OBJ, $FAKE_REGEX, $OBJECT, ], reject => [ $ZERO, $ONE, $INT, $NEG_INT, $NUM, $NEG_NUM, $EMPTY_STRING, $STRING, $NUM_IN_STRING, $INT_WITH_NL1, $INT_WITH_NL2, $SCALAR_REF, $SCALAR_REF_REF, $ARRAY_REF, $HASH_REF, $CODE_REF, $GLOB, $GLOB_REF, $FH, $UNDEF, ], }, ClassName => { accept => [ $CLASS_NAME, $ROLE_NAME, ], reject => [ $ZERO, $ONE, $INT, $NEG_INT, $NUM, $NEG_NUM, $EMPTY_STRING, $STRING, $NUM_IN_STRING, $INT_WITH_NL1, $INT_WITH_NL2, $SCALAR_REF, $SCALAR_REF_REF, $ARRAY_REF, $HASH_REF, $CODE_REF, $GLOB, $GLOB_REF, $FH, $FH_OBJECT, $REGEX, $REGEX_OBJ, $FAKE_REGEX, $OBJECT, $UNDEF, ], }, RoleName => { accept => [ $ROLE_NAME, ], reject => [ $CLASS_NAME, $ZERO, $ONE, $INT, $NEG_INT, $NUM, $NEG_NUM, $EMPTY_STRING, $STRING, $NUM_IN_STRING, $INT_WITH_NL1, $INT_WITH_NL2, $SCALAR_REF, $SCALAR_REF_REF, $ARRAY_REF, $HASH_REF, $CODE_REF, $GLOB, $GLOB_REF, $FH, $FH_OBJECT, $REGEX, $REGEX_OBJ, $FAKE_REGEX, $OBJECT, $UNDEF, ], }, ); for my $name ( sort keys %tests ) { test_constraint( $name, $tests{$name} ); test_constraint( Moose::Util::TypeConstraints::find_or_create_type_constraint( "$name|$name"), $tests{$name} ); } my %substr_test_str = ( ClassName => 'x' . $CLASS_NAME, RoleName => 'x' . $ROLE_NAME, ); # We need to test that the Str constraint (and types that derive from it) # accept the return val of substr() - which means passing that return val # directly to the checking code foreach my $type_name (qw(Str Num Int ClassName RoleName)) { my $str = $substr_test_str{$type_name} || '123456789'; my $type = Moose::Util::TypeConstraints::find_type_constraint($type_name); my $unoptimized = $type->has_parent ? $type->_compile_subtype( $type->constraint ) : $type->_compile_type( $type->constraint ); my $inlined; { $inlined = eval_closure( source => 'sub { ( ' . $type->_inline_check('$_[0]') . ' ) }', ); } ok( $type->check( substr( $str, 1, 5 ) ), $type_name . ' accepts return val from substr using ->check' ); ok( $unoptimized->( substr( $str, 1, 5 ) ), $type_name . ' accepts return val from substr using unoptimized constraint' ); ok( $inlined->( substr( $str, 1, 5 ) ), $type_name . ' accepts return val from substr using inlined constraint' ); # only Str accepts empty strings. next unless $type_name eq 'Str'; ok( $type->check( substr( $str, 0, 0 ) ), $type_name . ' accepts empty return val from substr using ->check' ); ok( $unoptimized->( substr( $str, 0, 0 ) ), $type_name . ' accepts empty return val from substr using unoptimized constraint' ); ok( $inlined->( substr( $str, 0, 0 ) ), $type_name . ' accepts empty return val from substr using inlined constraint' ); } { my $class_tc = class_type('Thing'); test_constraint( $class_tc, { accept => [ ( bless {}, 'Thing' ), ], reject => [ 'Thing', $ZERO, $ONE, $INT, $NEG_INT, $NUM, $NEG_NUM, $EMPTY_STRING, $STRING, $NUM_IN_STRING, $INT_WITH_NL1, $INT_WITH_NL2, $SCALAR_REF, $SCALAR_REF_REF, $ARRAY_REF, $HASH_REF, $CODE_REF, $GLOB, $GLOB_REF, $FH, $FH_OBJECT, $REGEX, $REGEX_OBJ, $FAKE_REGEX, $OBJECT, $UNDEF, ], } ); } { package Duck; sub quack { } sub flap { } } { package DuckLike; sub quack { } sub flap { } } { package Bird; sub flap { } } { my @methods = qw( quack flap ); duck_type 'Duck' => @methods; test_constraint( 'Duck', { accept => [ ( bless {}, 'Duck' ), ( bless {}, 'DuckLike' ), ], reject => [ $ZERO, $ONE, $INT, $NEG_INT, $NUM, $NEG_NUM, $EMPTY_STRING, $STRING, $NUM_IN_STRING, $INT_WITH_NL1, $INT_WITH_NL2, $SCALAR_REF, $SCALAR_REF_REF, $ARRAY_REF, $HASH_REF, $CODE_REF, $GLOB, $GLOB_REF, $FH, $FH_OBJECT, $REGEX, $REGEX_OBJ, $FAKE_REGEX, $OBJECT, ( bless {}, 'Bird' ), $UNDEF, ], } ); } { my @allowed = qw( bar baz quux ); enum 'Enumerated' => @allowed; test_constraint( 'Enumerated', { accept => \@allowed, reject => [ $ZERO, $ONE, $INT, $NEG_INT, $NUM, $NEG_NUM, $EMPTY_STRING, $STRING, $NUM_IN_STRING, $INT_WITH_NL1, $INT_WITH_NL2, $SCALAR_REF, $SCALAR_REF_REF, $ARRAY_REF, $HASH_REF, $CODE_REF, $GLOB, $GLOB_REF, $FH, $FH_OBJECT, $REGEX, $REGEX_OBJ, $FAKE_REGEX, $OBJECT, $UNDEF, ], } ); } { my $union = Moose::Meta::TypeConstraint::Union->new( type_constraints => [ find_type_constraint('Int'), find_type_constraint('Object'), ], ); test_constraint( $union, { accept => [ $ZERO, $ONE, $INT, $NEG_INT, $FH_OBJECT, $REGEX, $REGEX_OBJ, $FAKE_REGEX, $OBJECT, ], reject => [ $NUM, $NEG_NUM, $EMPTY_STRING, $STRING, $NUM_IN_STRING, $INT_WITH_NL1, $INT_WITH_NL2, $SCALAR_REF, $SCALAR_REF_REF, $ARRAY_REF, $HASH_REF, $CODE_REF, $GLOB, $GLOB_REF, $FH, $UNDEF, ], } ); } { note 'Anonymous Union Test'; my $union = union(['Int','Object']); test_constraint( $union, { accept => [ $ZERO, $ONE, $INT, $NEG_INT, $FH_OBJECT, $REGEX, $REGEX_OBJ, $FAKE_REGEX, $OBJECT, ], reject => [ $NUM, $NEG_NUM, $EMPTY_STRING, $STRING, $NUM_IN_STRING, $INT_WITH_NL1, $INT_WITH_NL2, $SCALAR_REF, $SCALAR_REF_REF, $ARRAY_REF, $HASH_REF, $CODE_REF, $GLOB, $GLOB_REF, $FH, $UNDEF, ], } ); } { note 'Named Union Test'; union 'NamedUnion' => ['Int','Object']; test_constraint( 'NamedUnion', { accept => [ $ZERO, $ONE, $INT, $NEG_INT, $FH_OBJECT, $REGEX, $REGEX_OBJ, $FAKE_REGEX, $OBJECT, ], reject => [ $NUM, $NEG_NUM, $EMPTY_STRING, $STRING, $NUM_IN_STRING, $INT_WITH_NL1, $INT_WITH_NL2, $SCALAR_REF, $SCALAR_REF_REF, $ARRAY_REF, $HASH_REF, $CODE_REF, $GLOB, $GLOB_REF, $FH, $UNDEF, ], } ); } { note 'Combined Union Test'; my $union = union( [ 'Int', enum( [qw[ red green blue ]] ) ] ); test_constraint( $union, { accept => [ $ZERO, $ONE, $INT, $NEG_INT, 'red', 'green', 'blue', ], reject => [ 'yellow', 'pink', $FH_OBJECT, $REGEX, $REGEX_OBJ, $FAKE_REGEX, $OBJECT, $NUM, $NEG_NUM, $EMPTY_STRING, $STRING, $NUM_IN_STRING, $INT_WITH_NL1, $INT_WITH_NL2, $SCALAR_REF, $SCALAR_REF_REF, $ARRAY_REF, $HASH_REF, $CODE_REF, $GLOB, $GLOB_REF, $FH, $UNDEF, ], } ); } { enum 'Enum1' => 'a', 'b'; enum 'Enum2' => 'x', 'y'; subtype 'EnumUnion', as 'Enum1 | Enum2'; test_constraint( 'EnumUnion', { accept => [qw( a b x y )], reject => [ $ZERO, $ONE, $INT, $NEG_INT, $NUM, $NEG_NUM, $EMPTY_STRING, $STRING, $NUM_IN_STRING, $INT_WITH_NL1, $INT_WITH_NL2, $SCALAR_REF, $SCALAR_REF_REF, $ARRAY_REF, $HASH_REF, $CODE_REF, $GLOB, $GLOB_REF, $FH, $FH_OBJECT, $REGEX, $REGEX_OBJ, $FAKE_REGEX, $OBJECT, $UNDEF, ], } ); } { package DoesRole; use Moose; with 'Role'; } # Test how $_ is used in XS implementation { local $_ = qr/./; ok( Moose::Util::TypeConstraints::Builtins::_RegexpRef(), '$_ is RegexpRef' ); ok( !Moose::Util::TypeConstraints::Builtins::_RegexpRef(1), '$_ is not read when param provided' ); $_ = bless qr/./, 'Blessed'; ok( Moose::Util::TypeConstraints::Builtins::_RegexpRef(), '$_ is RegexpRef' ); $_ = 42; ok( !Moose::Util::TypeConstraints::Builtins::_RegexpRef(), '$_ is not RegexpRef' ); ok( Moose::Util::TypeConstraints::Builtins::_RegexpRef(qr/./), '$_ is not read when param provided' ); } close $FH or warn "Could not close the filehandle $0 for test"; $FH_OBJECT->close or warn "Could not close the filehandle $0 for test"; done_testing; sub test_constraint { my $type = shift; my $tests = shift; local $Test::Builder::Level = $Test::Builder::Level + 1; unless ( blessed $type ) { $type = Moose::Util::TypeConstraints::find_type_constraint($type) or BAIL_OUT("No such type $type!"); } my $name = $type->name; my $unoptimized = $type->has_parent ? $type->_compile_subtype( $type->constraint ) : $type->_compile_type( $type->constraint ); my $inlined; if ( $type->can_be_inlined ) { $inlined = eval_closure( source => 'sub { ( ' . $type->_inline_check('$_[0]') . ' ) }', environment => $type->inline_environment, ); } my $class = Moose::Meta::Class->create_anon( superclasses => ['Moose::Object'], ); $class->add_attribute( simple => ( is => 'ro', isa => $type, ) ); $class->add_attribute( collection => ( traits => ['Array'], isa => 'ArrayRef[' . $type->name . ']', default => sub { [] }, handles => { add_to_collection => 'push' }, ) ); my $anon_class = $class->name; for my $accept ( @{ $tests->{accept} || [] } ) { my $described = describe($accept); ok( $type->check($accept), "$name accepts $described using ->check" ); ok( $unoptimized->($accept), "$name accepts $described using unoptimized constraint" ); if ($inlined) { ok( $inlined->($accept), "$name accepts $described using inlined constraint" ); } is( exception { $anon_class->new( simple => $accept ); }, undef, "no exception passing $described to constructor with $name" ); is( exception { $anon_class->new()->add_to_collection($accept); }, undef, "no exception passing $described to native trait push method with $name" ); } for my $reject ( @{ $tests->{reject} || [] } ) { my $described = describe($reject); ok( !$type->check($reject), "$name rejects $described using ->check" ); ok( !$unoptimized->($reject), "$name rejects $described using unoptimized constraint" ); if ($inlined) { ok( !$inlined->($reject), "$name rejects $described using inlined constraint" ); } ok( exception { $anon_class->new( simple => $reject ); }, "got exception passing $described to constructor with $name" ); ok( exception { $anon_class->new()->add_to_collection($reject); }, "got exception passing $described to native trait push method with $name" ); } } sub describe { my $val = shift; return 'undef' unless defined $val; if ( !ref $val ) { return q{''} if $val eq q{}; $val =~ s/\n/\\n/g; return $val; } return 'open filehandle' if openhandle $val && !blessed $val; return blessed $val ? ( ref $val ) . ' object' : ( ref $val ) . ' reference'; } Number.pm100644000767000024 455212200352345 23123 0ustar00etherstaff000000000000Moose-2.1005/lib/Moose/Meta/Attribute/Native/Traitpackage Moose::Meta::Attribute::Native::Trait::Number; BEGIN { $Moose::Meta::Attribute::Native::Trait::Number::AUTHORITY = 'cpan:STEVAN'; } { $Moose::Meta::Attribute::Native::Trait::Number::VERSION = '2.1005'; } use Moose::Role; with 'Moose::Meta::Attribute::Native::Trait'; sub _helper_type { 'Num' } no Moose::Role; 1; # ABSTRACT: Helper trait for Num attributes __END__ =pod =head1 NAME Moose::Meta::Attribute::Native::Trait::Number - Helper trait for Num attributes =head1 VERSION version 2.1005 =head1 SYNOPSIS package Real; use Moose; has 'integer' => ( traits => ['Number'], is => 'ro', isa => 'Num', default => 5, handles => { set => 'set', add => 'add', sub => 'sub', mul => 'mul', div => 'div', mod => 'mod', abs => 'abs', }, ); my $real = Real->new(); $real->add(5); # same as $real->integer($real->integer + 5); $real->sub(2); # same as $real->integer($real->integer - 2); =head1 DESCRIPTION This trait provides native delegation methods for numbers. All of the operations correspond to arithmetic operations like addition or multiplication. =head1 DEFAULT TYPE If you don't provide an C value for your attribute, it will default to C. =head1 PROVIDED METHODS All of these methods modify the attribute's value in place. All methods return the new value. =over 4 =item * B Adds the current value of the attribute to C<$value>. =item * B Subtracts C<$value> from the current value of the attribute. =item * B Multiplies the current value of the attribute by C<$value>. =item * B Divides the current value of the attribute by C<$value>. =item * B Returns the current value of the attribute modulo C<$value>. =item * B Sets the current value of the attribute to its absolute value. =back =head1 BUGS See L for details on reporting bugs. =head1 AUTHOR Moose is maintained by the Moose Cabal, along with the help of many contributors. See L and L for details. =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2013 by Infinity Interactive, Inc.. This is free software; you can redistribute it and/or modify it under the same terms as the Perl 5 programming language system itself. =cut String.pm100644000767000024 657612200352345 23151 0ustar00etherstaff000000000000Moose-2.1005/lib/Moose/Meta/Attribute/Native/Traitpackage Moose::Meta::Attribute::Native::Trait::String; BEGIN { $Moose::Meta::Attribute::Native::Trait::String::AUTHORITY = 'cpan:STEVAN'; } { $Moose::Meta::Attribute::Native::Trait::String::VERSION = '2.1005'; } use Moose::Role; with 'Moose::Meta::Attribute::Native::Trait'; sub _default_default { q{} } sub _default_is { 'rw' } sub _helper_type { 'Str' } no Moose::Role; 1; # ABSTRACT: Helper trait for Str attributes __END__ =pod =head1 NAME Moose::Meta::Attribute::Native::Trait::String - Helper trait for Str attributes =head1 VERSION version 2.1005 =head1 SYNOPSIS package MyHomePage; use Moose; has 'text' => ( traits => ['String'], is => 'rw', isa => 'Str', default => q{}, handles => { add_text => 'append', replace_text => 'replace', }, ); my $page = MyHomePage->new(); $page->add_text("foo"); # same as $page->text($page->text . "foo"); =head1 DESCRIPTION This trait provides native delegation methods for strings. =head1 DEFAULT TYPE If you don't provide an C value for your attribute, it will default to C. =head1 PROVIDED METHODS =over 4 =item * B Increments the value stored in this slot using the magical string autoincrement operator. Note that Perl doesn't provide analogous behavior in C<-->, so C is not available. This method returns the new value. This method does not accept any arguments. =item * B Appends to the string, like C<.=>, and returns the new value. This method requires a single argument. =item * B Prepends to the string and returns the new value. This method requires a single argument. =item * B Performs a regexp substitution (L). There is no way to provide the C flag, but code references will be accepted for the replacement, causing the regex to be modified with a single C. C can be applied using the C operator. This method returns the new value. This method requires two arguments. =item * B Runs the regex against the string and returns the matching value(s). This method requires a single argument. =item * B Just like L. This method returns the chopped character. This method does not accept any arguments. =item * B Just like L. This method returns the number of characters removed. This method does not accept any arguments. =item * B Sets the string to the empty string (not the value passed to C). This method does not have a defined return value. This method does not accept any arguments. =item * B Just like L, returns the length of the string. =item * B This acts just like L. When called as a writer, it returns the substring that was replaced, just like the Perl builtin. This method requires at least one argument, and accepts no more than three. =back =head1 BUGS See L for details on reporting bugs. =head1 AUTHOR Moose is maintained by the Moose Cabal, along with the help of many contributors. See L and L for details. =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2013 by Infinity Interactive, Inc.. This is free software; you can redistribute it and/or modify it under the same terms as the Perl 5 programming language system itself. =cut Reader.pm100644000767000024 222612200352345 23025 0ustar00etherstaff000000000000Moose-2.1005/lib/Moose/Meta/Method/Accessor/Nativepackage Moose::Meta::Method::Accessor::Native::Reader; BEGIN { $Moose::Meta::Method::Accessor::Native::Reader::AUTHORITY = 'cpan:STEVAN'; } { $Moose::Meta::Method::Accessor::Native::Reader::VERSION = '2.1005'; } use strict; use warnings; use Moose::Role; with 'Moose::Meta::Method::Accessor::Native'; requires '_return_value'; sub _generate_method { my $self = shift; my $inv = '$self'; my $slot_access = $self->_get_value($inv); return ( 'sub {', 'my ' . $inv . ' = shift;', $self->_inline_curried_arguments, $self->_inline_reader_core($inv, $slot_access, @_), '}', ); } sub _inline_reader_core { my $self = shift; my ($inv, $slot_access, @extra) = @_; return ( $self->_inline_check_argument_count, $self->_inline_process_arguments($inv, $slot_access), $self->_inline_check_arguments, $self->_inline_check_lazy($inv, '$type_constraint', '$type_coercion', '$type_message'), $self->_inline_return_value($slot_access), ); } sub _inline_process_arguments { return } sub _inline_check_arguments { return } no Moose::Role; 1; Writer.pm100644000767000024 1034512200352345 23120 0ustar00etherstaff000000000000Moose-2.1005/lib/Moose/Meta/Method/Accessor/Nativepackage Moose::Meta::Method::Accessor::Native::Writer; BEGIN { $Moose::Meta::Method::Accessor::Native::Writer::AUTHORITY = 'cpan:STEVAN'; } { $Moose::Meta::Method::Accessor::Native::Writer::VERSION = '2.1005'; } use strict; use warnings; use List::MoreUtils qw( any ); use Moose::Util; use Moose::Role; with 'Moose::Meta::Method::Accessor::Native'; requires '_potential_value'; sub _generate_method { my $self = shift; my $inv = '$self'; my $slot_access = $self->_get_value($inv); return ( 'sub {', 'my ' . $inv . ' = shift;', $self->_inline_curried_arguments, $self->_inline_writer_core($inv, $slot_access), '}', ); } sub _inline_writer_core { my $self = shift; my ($inv, $slot_access) = @_; my $potential = $self->_potential_value($slot_access); my $old = '@old'; my @code; push @code, ( $self->_inline_check_argument_count, $self->_inline_process_arguments($inv, $slot_access), $self->_inline_check_arguments('for writer'), $self->_inline_check_lazy($inv, '$type_constraint', '$type_coercion', '$type_message'), ); if ($self->_return_value($slot_access)) { # some writers will save the return value in this variable when they # generate the potential value. push @code, 'my @return;' } push @code, ( $self->_inline_coerce_new_values, $self->_inline_copy_native_value(\$potential), $self->_inline_tc_code($potential, '$type_constraint', '$type_coercion', '$type_message'), $self->_inline_get_old_value_for_trigger($inv, $old), $self->_inline_capture_return_value($slot_access), $self->_inline_set_new_value($inv, $potential, $slot_access), $self->_inline_trigger($inv, $slot_access, $old), $self->_inline_return_value($slot_access, 'for writer'), ); return @code; } sub _inline_process_arguments { return } sub _inline_check_arguments { return } sub _inline_coerce_new_values { return } sub _writer_value_needs_copy { my $self = shift; return $self->_constraint_must_be_checked; } sub _constraint_must_be_checked { my $self = shift; my $attr = $self->associated_attribute; return $attr->has_type_constraint && ( !$self->_is_root_type( $attr->type_constraint ) || ( $attr->should_coerce && $attr->type_constraint->has_coercion ) ); } sub _is_root_type { my $self = shift; my $type = shift; if ( Moose::Util::does_role( $type, 'Specio::Constraint::Role::Interface' ) ) { require Specio::Library::Builtins; return any { $type->is_same_type_as( Specio::Library::Builtins::t($_) ) } @{ $self->root_types }; } else { my $name = $type->name; return any { $name eq $_ } @{ $self->root_types }; } } sub _inline_copy_native_value { my $self = shift; my ($potential_ref) = @_; return unless $self->_writer_value_needs_copy; my $code = 'my $potential = ' . ${$potential_ref} . ';'; ${$potential_ref} = '$potential'; return $code; } around _inline_tc_code => sub { my $orig = shift; my $self = shift; my ($value, $tc, $coercion, $message, $for_lazy) = @_; return unless $for_lazy || $self->_constraint_must_be_checked; return $self->$orig(@_); }; around _inline_check_constraint => sub { my $orig = shift; my $self = shift; my ($value, $tc, $message, $for_lazy) = @_; return unless $for_lazy || $self->_constraint_must_be_checked; return $self->$orig(@_); }; sub _inline_capture_return_value { return } sub _inline_set_new_value { my $self = shift; return $self->_inline_store_value(@_) if $self->_writer_value_needs_copy || !$self->_slot_access_can_be_inlined || !$self->_get_is_lvalue; return $self->_inline_optimized_set_new_value(@_); } sub _get_is_lvalue { my $self = shift; return $self->associated_attribute->associated_class->instance_metaclass->inline_get_is_lvalue; } sub _inline_optimized_set_new_value { my $self = shift; return $self->_inline_store_value(@_); } sub _return_value { my $self = shift; my ($slot_access) = @_; return $slot_access; } no Moose::Role; 1; metaclass_compat_role_conflicts.t100644000767000024 213312200352345 23674 0ustar00etherstaff000000000000Moose-2.1005/t/metaclasses#!/usr/bin/env perl use strict; use warnings; use Test::More; BEGIN { package My::Meta::Role1; use Moose::Role; sub foo { 'Role1' } } BEGIN { package My::Meta::Role2; use Moose::Role; with 'My::Meta::Role1'; sub foo { 'Role2' } } BEGIN { package My::Extension; use Moose::Exporter; Moose::Exporter->setup_import_methods( class_metaroles => { class => ['My::Meta::Role2'], }, ); $INC{'My/Extension.pm'} = __FILE__; } BEGIN { package My::Meta::Role3; use Moose::Role; } BEGIN { package My::Extension2; use Moose::Exporter; Moose::Exporter->setup_import_methods( class_metaroles => { class => ['My::Meta::Role3'], }, ); $INC{'My/Extension2.pm'} = __FILE__; } { package My::Class1; use Moose; use My::Extension; } is(My::Class1->new->meta->foo, 'Role2'); { package My::Class2; use Moose; use My::Extension2; } { package My::Class3; use Moose; use My::Extension; extends 'My::Class2'; } is(My::Class3->new->meta->foo, 'Role2'); done_testing; custom_parameterized_types.t100644000767000024 621612200352345 24054 0ustar00etherstaff000000000000Moose-2.1005/t/type_constraints#!/usr/bin/perl use strict; use warnings; use Test::More; use Test::Fatal; use Moose::Util::TypeConstraints; use Moose::Meta::TypeConstraint::Parameterized; is( exception { subtype 'AlphaKeyHash' => as 'HashRef' => where { # no keys match non-alpha (grep { /[^a-zA-Z]/ } keys %$_) == 0 }; }, undef, '... created the subtype special okay' ); is( exception { subtype 'Trihash' => as 'AlphaKeyHash' => where { keys(%$_) == 3 }; }, undef, '... created the subtype special okay' ); is( exception { subtype 'Noncon' => as 'Item'; }, undef, '... created the subtype special okay' ); { my $t = find_type_constraint('AlphaKeyHash'); isa_ok($t, 'Moose::Meta::TypeConstraint'); is($t->name, 'AlphaKeyHash', '... name is correct'); my $p = $t->parent; isa_ok($p, 'Moose::Meta::TypeConstraint'); is($p->name, 'HashRef', '... parent name is correct'); ok($t->check({ one => 1, two => 2 }), '... validated it correctly'); ok(!$t->check({ one1 => 1, two2 => 2 }), '... validated it correctly'); ok( $t->equals($t), "equals to self" ); ok( !$t->equals($t->parent), "not equal to parent" ); } my $hoi = Moose::Util::TypeConstraints::find_or_parse_type_constraint('AlphaKeyHash[Int]'); ok($hoi->check({ one => 1, two => 2 }), '... validated it correctly'); ok(!$hoi->check({ one1 => 1, two2 => 2 }), '... validated it correctly'); ok(!$hoi->check({ one => 'uno', two => 'dos' }), '... validated it correctly'); ok(!$hoi->check({ one1 => 'un', two2 => 'deux' }), '... validated it correctly'); ok( $hoi->equals($hoi), "equals to self" ); ok( !$hoi->equals($hoi->parent), "equals to self" ); ok( !$hoi->equals(find_type_constraint('AlphaKeyHash')), "not equal to unparametrized self" ); ok( $hoi->equals( Moose::Meta::TypeConstraint::Parameterized->new( name => "Blah", parent => find_type_constraint("AlphaKeyHash"), type_parameter => find_type_constraint("Int") ) ), "equal to clone" ); ok( !$hoi->equals( Moose::Meta::TypeConstraint::Parameterized->new( name => "Oink", parent => find_type_constraint("AlphaKeyHash"), type_parameter => find_type_constraint("Str") ) ), "not equal to different parameter" ); my $th = Moose::Util::TypeConstraints::find_or_parse_type_constraint('Trihash[Bool]'); ok(!$th->check({ one => 1, two => 1 }), '... validated it correctly'); ok($th->check({ one => 1, two => 0, three => 1 }), '... validated it correctly'); ok(!$th->check({ one => 1, two => 2, three => 1 }), '... validated it correctly'); ok(!$th->check({foo1 => 1, bar2 => 0, baz3 => 1}), '... validated it correctly'); isnt( exception { Moose::Meta::TypeConstraint::Parameterized->new( name => 'Str[Int]', parent => find_type_constraint('Str'), type_parameter => find_type_constraint('Int'), ); }, undef, 'non-containers cannot be parameterized' ); isnt( exception { Moose::Meta::TypeConstraint::Parameterized->new( name => 'Noncon[Int]', parent => find_type_constraint('Noncon'), type_parameter => find_type_constraint('Int'), ); }, undef, 'non-containers cannot be parameterized' ); done_testing; subtype_auto_vivify_parent.t100644000767000024 114012200352345 24061 0ustar00etherstaff000000000000Moose-2.1005/t/type_constraints#!/usr/bin/perl use strict; use warnings; use Test::More; use Moose::Util::TypeConstraints; { package Foo; sub new { my $class = shift; return bless {@_}, $class; } } subtype 'FooWithSize' => as 'Foo' => where { $_[0]->{size} }; my $type = find_type_constraint('FooWithSize'); ok( $type, 'made a FooWithSize constraint' ); ok( $type->parent, 'type has a parent type' ); is( $type->parent->name, 'Foo', 'parent type is Foo' ); isa_ok( $type->parent, 'Moose::Meta::TypeConstraint::Class', 'parent type constraint is a class type' ); done_testing; basics_binarytree_attributefeatures.t100644000767000024 751712200352345 23743 0ustar00etherstaff000000000000Moose-2.1005/t/recipes#!/usr/bin/perl -w use strict; use Test::More 'no_plan'; use Test::Fatal; $| = 1; # =begin testing SETUP { package BinaryTree; use Moose; has 'node' => ( is => 'rw', isa => 'Any' ); has 'parent' => ( is => 'rw', isa => 'BinaryTree', predicate => 'has_parent', weak_ref => 1, ); has 'left' => ( is => 'rw', isa => 'BinaryTree', predicate => 'has_left', lazy => 1, default => sub { BinaryTree->new( parent => $_[0] ) }, trigger => \&_set_parent_for_child ); has 'right' => ( is => 'rw', isa => 'BinaryTree', predicate => 'has_right', lazy => 1, default => sub { BinaryTree->new( parent => $_[0] ) }, trigger => \&_set_parent_for_child ); sub _set_parent_for_child { my ( $self, $child ) = @_; confess "You cannot insert a tree which already has a parent" if $child->has_parent; $child->parent($self); } } # =begin testing { use Scalar::Util 'isweak'; my $root = BinaryTree->new(node => 'root'); isa_ok($root, 'BinaryTree'); is($root->node, 'root', '... got the right node value'); ok(!$root->has_left, '... no left node yet'); ok(!$root->has_right, '... no right node yet'); ok(!$root->has_parent, '... no parent for root node'); # make a left node my $left = $root->left; isa_ok($left, 'BinaryTree'); is($root->left, $left, '... got the same node (and it is $left)'); ok($root->has_left, '... we have a left node now'); ok($left->has_parent, '... lefts has a parent'); is($left->parent, $root, '... lefts parent is the root'); ok(isweak($left->{parent}), '... parent is a weakened ref'); ok(!$left->has_left, '... $left no left node yet'); ok(!$left->has_right, '... $left no right node yet'); is($left->node, undef, '... left has got no node value'); is( exception { $left->node('left'); }, undef, '... assign to lefts node' ); is($left->node, 'left', '... left now has a node value'); # make a right node ok(!$root->has_right, '... still no right node yet'); is($root->right->node, undef, '... right has got no node value'); ok($root->has_right, '... now we have a right node'); my $right = $root->right; isa_ok($right, 'BinaryTree'); is( exception { $right->node('right'); }, undef, '... assign to rights node' ); is($right->node, 'right', '... left now has a node value'); is($root->right, $right, '... got the same node (and it is $right)'); ok($root->has_right, '... we have a right node now'); ok($right->has_parent, '... rights has a parent'); is($right->parent, $root, '... rights parent is the root'); ok(isweak($right->{parent}), '... parent is a weakened ref'); # make a left node of the left node my $left_left = $left->left; isa_ok($left_left, 'BinaryTree'); ok($left_left->has_parent, '... left does have a parent'); is($left_left->parent, $left, '... got a parent node (and it is $left)'); ok($left->has_left, '... we have a left node now'); is($left->left, $left_left, '... got a left node (and it is $left_left)'); ok(isweak($left_left->{parent}), '... parent is a weakened ref'); # make a right node of the left node my $left_right = BinaryTree->new; isa_ok($left_right, 'BinaryTree'); is( exception { $left->right($left_right); }, undef, '... assign to rights node' ); ok($left_right->has_parent, '... left does have a parent'); is($left_right->parent, $left, '... got a parent node (and it is $left)'); ok($left->has_right, '... we have a left node now'); is($left->right, $left_right, '... got a left node (and it is $left_left)'); ok(isweak($left_right->{parent}), '... parent is a weakened ref'); # and check the error isnt( exception { $left_right->right($left_left); }, undef, '... cannot assign a node which already has a parent' ); } 1; Table_MetaclassTrait.pod100644000767000024 612612200352345 23361 0ustar00etherstaff000000000000Moose-2.1005/lib/Moose/Cookbook/Metapackage Moose::Cookbook::Meta::Table_MetaclassTrait; # ABSTRACT: Adding a "table" attribute as a metaclass trait __END__ =pod =head1 NAME Moose::Cookbook::Meta::Table_MetaclassTrait - Adding a "table" attribute as a metaclass trait =head1 VERSION version 2.1005 =head1 SYNOPSIS # in lib/MyApp/Meta/Class/Trait/HasTable.pm package MyApp::Meta::Class::Trait::HasTable; use Moose::Role; Moose::Util::meta_class_alias('HasTable'); has table => ( is => 'rw', isa => 'Str', ); # in lib/MyApp/User.pm package MyApp::User; use Moose -traits => 'HasTable'; __PACKAGE__->meta->table('User'); =head1 DESCRIPTION In this recipe, we'll create a class metaclass trait which has a "table" attribute. This trait is for classes associated with a DBMS table, as one might do for an ORM. In this example, the table name is just a string, but in a real ORM the table might be an object describing the table. =begin testing-SETUP BEGIN { package MyApp::Meta::Class::Trait::HasTable; use Moose::Role; Moose::Util::meta_class_alias('HasTable'); has table => ( is => 'rw', isa => 'Str', ); } =end testing-SETUP =head1 THE METACLASS TRAIT This really is as simple as the recipe L shows. The trick is getting your classes to use this metaclass, and providing some sort of sugar for declaring the table. This is covered in L, which shows how to make a module like C itself, with sugar like C. =head2 Using this Metaclass Trait in Practice Accessing this new C attribute is quite simple. Given a class named C, we could simply write the following: my $table = MyApp::User->meta->table; As long as C has arranged to apply the C to its metaclass, this method call just works. If we want to be more careful, we can check that the class metaclass object has a C
method: $table = MyApp::User->meta->table if MyApp::User->meta->can('table'); In theory, this is not entirely correct, since the metaclass might be getting its C
method from a I trait. In practice, you are unlikely to encounter this sort of problem. =head1 RECIPE CAVEAT This recipe doesn't work when you paste it all into a single file. This is because the C<< use Moose -traits => 'HasTable'; >> line ends up being executed before the C
attribute is defined. When the two packages are separate files, this just works. =head1 SEE ALSO L - Labels implemented via attribute traits =for testing can_ok( MyApp::User->meta, 'table' ); is( MyApp::User->meta->table, 'User', 'My::User table is User' ); =head1 AUTHOR Moose is maintained by the Moose Cabal, along with the help of many contributors. See L and L for details. =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2013 by Infinity Interactive, Inc.. This is free software; you can redistribute it and/or modify it under the same terms as the Perl 5 programming language system itself. =cut Counter.pm100644000767000024 517012200352345 23307 0ustar00etherstaff000000000000Moose-2.1005/lib/Moose/Meta/Attribute/Native/Trait package Moose::Meta::Attribute::Native::Trait::Counter; BEGIN { $Moose::Meta::Attribute::Native::Trait::Counter::AUTHORITY = 'cpan:STEVAN'; } { $Moose::Meta::Attribute::Native::Trait::Counter::VERSION = '2.1005'; } use Moose::Role; with 'Moose::Meta::Attribute::Native::Trait'; sub _default_default { 0 } sub _default_is { 'ro' } sub _helper_type { 'Num' } sub _root_types { 'Num', 'Int' } no Moose::Role; 1; # ABSTRACT: Helper trait for Int attributes which represent counters __END__ =pod =head1 NAME Moose::Meta::Attribute::Native::Trait::Counter - Helper trait for Int attributes which represent counters =head1 VERSION version 2.1005 =head1 SYNOPSIS package MyHomePage; use Moose; has 'counter' => ( traits => ['Counter'], is => 'ro', isa => 'Num', default => 0, handles => { inc_counter => 'inc', dec_counter => 'dec', reset_counter => 'reset', }, ); my $page = MyHomePage->new(); $page->inc_counter; # same as $page->counter( $page->counter + 1 ); $page->dec_counter; # same as $page->counter( $page->counter - 1 ); my $count_by_twos = 2; $page->inc_counter($count_by_twos); =head1 DESCRIPTION This trait provides native delegation methods for counters. A counter can be any sort of number (integer or not). The delegation methods allow you to increment, decrement, or reset the value. =head1 DEFAULT TYPE If you don't provide an C value for your attribute, it will default to C. =head1 PROVIDED METHODS =over 4 =item * B Sets the counter to the specified value and returns the new value. This method requires a single argument. =item * B =item * B Increases the attribute value by the amount of the argument, or by 1 if no argument is given. This method returns the new value. This method accepts a single argument. =item * B =item * B Decreases the attribute value by the amount of the argument, or by 1 if no argument is given. This method returns the new value. This method accepts a single argument. =item * B Resets the value stored in this slot to its default value, and returns the new value. =back =head1 BUGS See L for details on reporting bugs. =head1 AUTHOR Moose is maintained by the Moose Cabal, along with the help of many contributors. See L and L for details. =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2013 by Infinity Interactive, Inc.. This is free software; you can redistribute it and/or modify it under the same terms as the Perl 5 programming language system itself. =cut Hash000755000767000024 012200352345 22006 5ustar00etherstaff000000000000Moose-2.1005/lib/Moose/Meta/Method/Accessor/Nativekv.pm100644000767000024 112612200352345 23124 0ustar00etherstaff000000000000Moose-2.1005/lib/Moose/Meta/Method/Accessor/Native/Hashpackage Moose::Meta::Method::Accessor::Native::Hash::kv; BEGIN { $Moose::Meta::Method::Accessor::Native::Hash::kv::AUTHORITY = 'cpan:STEVAN'; } { $Moose::Meta::Method::Accessor::Native::Hash::kv::VERSION = '2.1005'; } use strict; use warnings; use Scalar::Util qw( looks_like_number ); use Moose::Role; with 'Moose::Meta::Method::Accessor::Native::Reader'; sub _maximum_arguments { 0 } sub _return_value { my $self = shift; my ($slot_access) = @_; return 'map { [ $_, ' . $slot_access . '->{$_} ] } ' . 'keys %{ (' . $slot_access . ') }'; } no Moose::Role; 1; RoleSummation.pm100644000767000024 2157112200352345 23401 0ustar00etherstaff000000000000Moose-2.1005/lib/Moose/Meta/Role/Applicationpackage Moose::Meta::Role::Application::RoleSummation; BEGIN { $Moose::Meta::Role::Application::RoleSummation::AUTHORITY = 'cpan:STEVAN'; } { $Moose::Meta::Role::Application::RoleSummation::VERSION = '2.1005'; } use strict; use warnings; use metaclass; use Scalar::Util 'blessed'; use Moose::Meta::Role::Composite; use base 'Moose::Meta::Role::Application'; __PACKAGE__->meta->add_attribute('role_params' => ( reader => 'role_params', default => sub { {} }, Class::MOP::_definition_context(), )); sub get_exclusions_for_role { my ($self, $role) = @_; $role = $role->name if blessed $role; my $excludes_key = exists $self->role_params->{$role}->{'-excludes'} ? '-excludes' : 'excludes'; if ($self->role_params->{$role} && defined $self->role_params->{$role}->{$excludes_key}) { if (ref $self->role_params->{$role}->{$excludes_key} eq 'ARRAY') { return $self->role_params->{$role}->{$excludes_key}; } return [ $self->role_params->{$role}->{$excludes_key} ]; } return []; } sub get_method_aliases_for_role { my ($self, $role) = @_; $role = $role->name if blessed $role; my $alias_key = exists $self->role_params->{$role}->{'-alias'} ? '-alias' : 'alias'; if ($self->role_params->{$role} && defined $self->role_params->{$role}->{$alias_key}) { return $self->role_params->{$role}->{$alias_key}; } return {}; } sub is_method_excluded { my ($self, $role, $method_name) = @_; foreach ($self->get_exclusions_for_role($role->name)) { return 1 if $_ eq $method_name; } return 0; } sub is_method_aliased { my ($self, $role, $method_name) = @_; exists $self->get_method_aliases_for_role($role->name)->{$method_name} ? 1 : 0 } sub is_aliased_method { my ($self, $role, $method_name) = @_; my %aliased_names = reverse %{$self->get_method_aliases_for_role($role->name)}; exists $aliased_names{$method_name} ? 1 : 0; } sub check_role_exclusions { my ($self, $c) = @_; my %excluded_roles; for my $role (@{ $c->get_roles }) { my $name = $role->name; for my $excluded ($role->get_excluded_roles_list) { push @{ $excluded_roles{$excluded} }, $name; } } foreach my $role (@{$c->get_roles}) { foreach my $excluded (keys %excluded_roles) { next unless $role->does_role($excluded); my @excluding = @{ $excluded_roles{$excluded} }; require Moose; Moose->throw_error(sprintf "Conflict detected: Role%s %s exclude%s role '%s'", (@excluding == 1 ? '' : 's'), join(', ', @excluding), (@excluding == 1 ? 's' : ''), $excluded); } } $c->add_excluded_roles(keys %excluded_roles); } sub check_required_methods { my ($self, $c) = @_; my %all_required_methods = map { $_->name => $_ } map { $_->get_required_method_list } @{$c->get_roles}; foreach my $role (@{$c->get_roles}) { foreach my $required (keys %all_required_methods) { delete $all_required_methods{$required} if $role->has_method($required) || $self->is_aliased_method($role, $required); } } $c->add_required_methods(values %all_required_methods); } sub check_required_attributes { } sub apply_attributes { my ($self, $c) = @_; my @all_attributes; for my $role ( @{ $c->get_roles } ) { push @all_attributes, map { $role->get_attribute($_) } $role->get_attribute_list; } my %seen; foreach my $attr (@all_attributes) { my $name = $attr->name; if ( exists $seen{$name} ) { next if $seen{$name}->is_same_as($attr); my $role1 = $seen{$name}->associated_role->name; my $role2 = $attr->associated_role->name; require Moose; Moose->throw_error( "We have encountered an attribute conflict with '$name' " . "during role composition. " . " This attribute is defined in both $role1 and $role2." . " This is a fatal error and cannot be disambiguated." ); } $seen{$name} = $attr; } foreach my $attr (@all_attributes) { $c->add_attribute( $attr->clone ); } } sub apply_methods { my ($self, $c) = @_; my @all_methods = map { my $role = $_; my $aliases = $self->get_method_aliases_for_role($role); my %excludes = map { $_ => undef } @{ $self->get_exclusions_for_role($role) }; ( (map { exists $excludes{$_} ? () : +{ role => $role, name => $_, method => $role->get_method($_), } } map { $_->name } grep { !$_->isa('Class::MOP::Method::Meta') } $role->_get_local_methods), (map { +{ role => $role, name => $aliases->{$_}, method => $role->get_method($_), } } keys %$aliases) ); } @{$c->get_roles}; my (%seen, %conflicts, %method_map); foreach my $method (@all_methods) { next if $conflicts{$method->{name}}; my $seen = $seen{$method->{name}}; if ($seen) { if ($seen->{method}->body != $method->{method}->body) { $c->add_conflicting_method( name => $method->{name}, roles => [$method->{role}->name, $seen->{role}->name], ); delete $method_map{$method->{name}}; $conflicts{$method->{name}} = 1; next; } } $seen{$method->{name}} = $method; $method_map{$method->{name}} = $method->{method}; } $c->add_method($_ => $method_map{$_}) for keys %method_map; } sub apply_override_method_modifiers { my ($self, $c) = @_; my @all_overrides = map { my $role = $_; map { +{ name => $_, method => $role->get_override_method_modifier($_), } } $role->get_method_modifier_list('override'); } @{$c->get_roles}; my %seen; foreach my $override (@all_overrides) { if ( $c->has_method($override->{name}) ){ require Moose; Moose->throw_error( "Role '" . $c->name . "' has encountered an 'override' method conflict " . "during composition (A local method of the same name as been found). This " . "is fatal error." ) } if (exists $seen{$override->{name}}) { if ( $seen{$override->{name}} != $override->{method} ) { require Moose; Moose->throw_error( "We have encountered an 'override' method conflict during " . "composition (Two 'override' methods of the same name encountered). " . "This is fatal error.") } } $seen{$override->{name}} = $override->{method}; } $c->add_override_method_modifier( $_->{name}, $_->{method} ) for @all_overrides; } sub apply_method_modifiers { my ($self, $modifier_type, $c) = @_; my $add = "add_${modifier_type}_method_modifier"; my $get = "get_${modifier_type}_method_modifiers"; foreach my $role (@{$c->get_roles}) { foreach my $method_name ($role->get_method_modifier_list($modifier_type)) { $c->$add( $method_name, $_ ) foreach $role->$get($method_name); } } } 1; # ABSTRACT: Combine two or more roles __END__ =pod =head1 NAME Moose::Meta::Role::Application::RoleSummation - Combine two or more roles =head1 VERSION version 2.1005 =head1 DESCRIPTION Summation composes two traits, forming the union of non-conflicting bindings and 'disabling' the conflicting bindings =head2 METHODS =over 4 =item B =item B =item B =item B =item B =item B =item B =item B =item B =item B =item B =item B =item B =item B =item B =item B =back =head1 BUGS See L for details on reporting bugs. =head1 AUTHOR Moose is maintained by the Moose Cabal, along with the help of many contributors. See L and L for details. =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2013 by Infinity Interactive, Inc.. This is free software; you can redistribute it and/or modify it under the same terms as the Perl 5 programming language system itself. =cut Parameterizable.pm100644000767000024 1043612200352345 23532 0ustar00etherstaff000000000000Moose-2.1005/lib/Moose/Meta/TypeConstraintpackage Moose::Meta::TypeConstraint::Parameterizable; BEGIN { $Moose::Meta::TypeConstraint::Parameterizable::AUTHORITY = 'cpan:STEVAN'; } { $Moose::Meta::TypeConstraint::Parameterizable::VERSION = '2.1005'; } use strict; use warnings; use metaclass; use base 'Moose::Meta::TypeConstraint'; use Moose::Meta::TypeConstraint::Parameterized; use Moose::Util::TypeConstraints (); use Carp 'confess'; __PACKAGE__->meta->add_attribute('constraint_generator' => ( accessor => 'constraint_generator', predicate => 'has_constraint_generator', Class::MOP::_definition_context(), )); __PACKAGE__->meta->add_attribute('inline_generator' => ( accessor => 'inline_generator', predicate => 'has_inline_generator', Class::MOP::_definition_context(), )); sub generate_constraint_for { my ($self, $type) = @_; return unless $self->has_constraint_generator; return $self->constraint_generator->($type->type_parameter) if $type->is_subtype_of($self->name); return $self->_can_coerce_constraint_from($type) if $self->has_coercion && $self->coercion->has_coercion_for_type($type->parent->name); return; } sub _can_coerce_constraint_from { my ($self, $type) = @_; my $coercion = $self->coercion; my $constraint = $self->constraint_generator->($type->type_parameter); return sub { local $_ = $coercion->coerce($_); $constraint->(@_); }; } sub generate_inline_for { my ($self, $type, $val) = @_; confess "Can't generate an inline constraint for $type, since none " . "was defined" unless $self->has_inline_generator; return '( do { ' . $self->inline_generator->( $self, $type, $val ) . ' } )'; } sub _parse_type_parameter { my ($self, $type_parameter) = @_; return Moose::Util::TypeConstraints::find_or_create_isa_type_constraint($type_parameter); } sub parameterize { my ($self, $type_parameter) = @_; my $contained_tc = $self->_parse_type_parameter($type_parameter); ## The type parameter should be a subtype of the parent's type parameter ## if there is one. if(my $parent = $self->parent) { if($parent->can('type_parameter')) { unless ( $contained_tc->is_a_type_of($parent->type_parameter) ) { require Moose; Moose->throw_error("$type_parameter is not a subtype of ".$parent->type_parameter); } } } if ( $contained_tc->isa('Moose::Meta::TypeConstraint') ) { my $tc_name = $self->name . '[' . $contained_tc->name . ']'; return Moose::Meta::TypeConstraint::Parameterized->new( name => $tc_name, parent => $self, type_parameter => $contained_tc, parameterized_from => $self, ); } else { require Moose; Moose->throw_error("The type parameter must be a Moose meta type"); } } 1; # ABSTRACT: Type constraints which can take a parameter (ArrayRef) __END__ =pod =head1 NAME Moose::Meta::TypeConstraint::Parameterizable - Type constraints which can take a parameter (ArrayRef) =head1 VERSION version 2.1005 =head1 DESCRIPTION This class represents a parameterizable type constraint. This is a type constraint like C or C, that can be parameterized and made more specific by specifying a contained type. For example, instead of just an C of anything, you can specify that is an C. A parameterizable constraint should not be used as an attribute type constraint. Instead, when parameterized it creates a L which should be used. =head1 INHERITANCE C is a subclass of L. =head1 METHODS This class is intentionally not documented because the API is confusing and needs some work. =head1 BUGS See L for details on reporting bugs. =head1 AUTHOR Moose is maintained by the Moose Cabal, along with the help of many contributors. See L and L for details. =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2013 by Infinity Interactive, Inc.. This is free software; you can redistribute it and/or modify it under the same terms as the Perl 5 programming language system itself. =cut immutable_trigger_from_constructor.t100644000767000024 144412200352345 24141 0ustar00etherstaff000000000000Moose-2.1005/t/immutable#!/usr/bin/perl use strict; use warnings; use Test::More; use Test::Fatal; { package AClass; use Moose; has 'foo' => (is => 'rw', isa => 'Maybe[Str]', trigger => sub { die "Pulling the Foo trigger\n" }); has 'bar' => (is => 'rw', isa => 'Maybe[Str]'); has 'baz' => (is => 'rw', isa => 'Maybe[Str]', trigger => sub { die "Pulling the Baz trigger\n" }); __PACKAGE__->meta->make_immutable; #(debug => 1); no Moose; } eval { AClass->new(foo => 'bar') }; like ($@, qr/^Pulling the Foo trigger/, "trigger from immutable constructor"); eval { AClass->new(baz => 'bar') }; like ($@, qr/^Pulling the Baz trigger/, "trigger from immutable constructor"); is( exception { AClass->new(bar => 'bar') }, undef, '... no triggers called' ); done_testing; coerced_parameterized_types.t100644000767000024 335112200352345 24143 0ustar00etherstaff000000000000Moose-2.1005/t/type_constraints#!/usr/bin/perl use strict; use warnings; use Test::More; use Test::Fatal; use Moose::Util::TypeConstraints; use Moose::Meta::TypeConstraint::Parameterized; BEGIN { package MyList; sub new { my $class = shift; bless { items => \@_ }, $class; } sub items { my $self = shift; return @{ $self->{items} }; } } subtype 'MyList' => as 'Object' => where { $_->isa('MyList') }; is( exception { coerce 'ArrayRef' => from 'MyList' => via { [ $_->items ] } }, undef, '... created the coercion okay' ); my $mylist = Moose::Util::TypeConstraints::find_or_parse_type_constraint('MyList[Int]'); ok($mylist->check(MyList->new(10, 20, 30)), '... validated it correctly (pass)'); ok(!$mylist->check(MyList->new(10, "two")), '... validated it correctly (fail)'); ok(!$mylist->check([10]), '... validated it correctly (fail)'); subtype 'EvenList' => as 'MyList' => where { $_->items % 2 == 0 }; # XXX: get this to work *without* the declaration. I suspect it'll be a new # method in Moose::Meta::TypeCoercion that will look at the parents of the # coerced type as well. but will that be too "action at a distance"-ey? is( exception { coerce 'ArrayRef' => from 'EvenList' => via { [ $_->items ] } }, undef, '... created the coercion okay' ); my $evenlist = Moose::Util::TypeConstraints::find_or_parse_type_constraint('EvenList[Int]'); ok(!$evenlist->check(MyList->new(10, 20, 30)), '... validated it correctly (fail)'); ok($evenlist->check(MyList->new(10, 20, 30, 40)), '... validated it correctly (pass)'); ok(!$evenlist->check(MyList->new(10, "two")), '... validated it correctly (fail)'); ok(!$evenlist->check([10, 20]), '... validated it correctly (fail)'); done_testing; meta_privateorpublic_methodmetaclass.t100644000767000024 363712200352345 24105 0ustar00etherstaff000000000000Moose-2.1005/t/recipes#!/usr/bin/perl -w use strict; use Test::More 'no_plan'; use Test::Fatal; $| = 1; # =begin testing SETUP { package MyApp::Meta::Method::PrivateOrPublic; use Moose; use Moose::Util::TypeConstraints; extends 'Moose::Meta::Method'; has '_policy' => ( is => 'ro', isa => enum( [ qw( public private ) ] ), default => 'public', init_arg => 'policy', ); sub new { my $class = shift; my %options = @_; my $self = $class->SUPER::wrap(%options); $self->{_policy} = $options{policy}; $self->_add_policy_wrapper; return $self; } sub _add_policy_wrapper { my $self = shift; return if $self->is_public; my $name = $self->name; my $package = $self->package_name; my $real_body = $self->body; my $body = sub { die "The $package\::$name method is private" unless ( scalar caller() ) eq $package; goto &{$real_body}; }; $self->{body} = $body; } sub is_public { $_[0]->_policy eq 'public' } sub is_private { $_[0]->_policy eq 'private' } package MyApp::User; use Moose; has 'password' => ( is => 'rw' ); __PACKAGE__->meta()->add_method( '_reset_password', MyApp::Meta::Method::PrivateOrPublic->new( name => '_reset_password', package_name => __PACKAGE__, body => sub { $_[0]->password('reset') }, policy => 'private', ) ); } # =begin testing { package main; use Test::Fatal; my $user = MyApp::User->new( password => 'foo!' ); like( exception { $user->_reset_password }, qr/The MyApp::User::_reset_password method is private/, '_reset_password method dies if called outside MyApp::User class'); { package MyApp::User; sub run_reset { $_[0]->_reset_password } } $user->run_reset; is( $user->password, 'reset', 'password has been reset' ); } 1; Roles000755000767000024 012200352345 16657 5ustar00etherstaff000000000000Moose-2.1005/lib/Moose/CookbookComparable_CodeReuse.pod100644000767000024 2263612200352345 23557 0ustar00etherstaff000000000000Moose-2.1005/lib/Moose/Cookbook/Rolespackage Moose::Cookbook::Roles::Comparable_CodeReuse; # ABSTRACT: Using roles for code reuse __END__ =pod =head1 NAME Moose::Cookbook::Roles::Comparable_CodeReuse - Using roles for code reuse =head1 VERSION version 2.1005 =head1 SYNOPSIS package Eq; use Moose::Role; requires 'equal_to'; sub not_equal_to { my ( $self, $other ) = @_; not $self->equal_to($other); } package Comparable; use Moose::Role; with 'Eq'; requires 'compare'; sub equal_to { my ( $self, $other ) = @_; $self->compare($other) == 0; } sub greater_than { my ( $self, $other ) = @_; $self->compare($other) == 1; } sub less_than { my ( $self, $other ) = @_; $self->compare($other) == -1; } sub greater_than_or_equal_to { my ( $self, $other ) = @_; $self->greater_than($other) || $self->equal_to($other); } sub less_than_or_equal_to { my ( $self, $other ) = @_; $self->less_than($other) || $self->equal_to($other); } package Printable; use Moose::Role; requires 'to_string'; package US::Currency; use Moose; with 'Comparable', 'Printable'; has 'amount' => ( is => 'rw', isa => 'Num', default => 0 ); sub compare { my ( $self, $other ) = @_; $self->amount <=> $other->amount; } sub to_string { my $self = shift; sprintf '$%0.2f USD' => $self->amount; } =head1 DESCRIPTION Roles have two primary purposes: as interfaces, and as a means of code reuse. This recipe demonstrates the latter, with roles that define comparison and display code for objects. Let's start with C. First, note that we've replaced C with C. We also have a new sugar function, C: requires 'equal_to'; This says that any class which consumes this role must provide an C method. It can provide this method directly, or by consuming some other role. The C role defines its C method in terms of the required C method. This lets us minimize the methods that consuming classes must provide. The next role, C, builds on the C role. We include C in C using C, another new sugar function: with 'Eq'; The C function takes a list of roles to consume. In our example, the C role provides the C method required by C. However, it could opt not to, in which case a class that consumed C would have to provide its own C. In other words, a role can consume another role I providing any required methods. The C role requires a method, C: requires 'compare'; The C role also provides a number of other methods, all of which ultimately rely on C. sub equal_to { my ( $self, $other ) = @_; $self->compare($other) == 0; } sub greater_than { my ( $self, $other ) = @_; $self->compare($other) == 1; } sub less_than { my ( $self, $other ) = @_; $self->compare($other) == -1; } sub greater_than_or_equal_to { my ( $self, $other ) = @_; $self->greater_than($other) || $self->equal_to($other); } sub less_than_or_equal_to { my ( $self, $other ) = @_; $self->less_than($other) || $self->equal_to($other); } Finally, we define the C role. This role exists solely to provide an interface. It has no methods, just a list of required methods. In this case, it just requires a C method. An interface role is useful because it defines both a method and a I. We know that any class which does this role has a C method, but we can also assume that this method has the semantics we want. Presumably, in real code we would define those semantics in the documentation for the C role. (1) Finally, we have the C class which consumes both the C and C roles. with 'Comparable', 'Printable'; It also defines a regular Moose attribute, C: has 'amount' => ( is => 'rw', isa => 'Num', default => 0 ); Finally we see the implementation of the methods required by our roles. We have a C method: sub compare { my ( $self, $other ) = @_; $self->amount <=> $other->amount; } By consuming the C role and defining this method, we gain the following methods for free: C, C, C, C and C. Then we have our C method: sub to_string { my $self = shift; sprintf '$%0.2f USD' => $self->amount; } =head1 CONCLUSION Roles can be very powerful. They are a great way of encapsulating reusable behavior, as well as communicating (semantic and interface) information about the methods our classes provide. =head1 FOOTNOTES =over 4 =item (1) Consider two classes, C and C, both of which define a C method. If we just require that an object implements a C method, we still aren't saying anything about what that method I. If we require an object that implements the C role, we're saying something about semantics. =back =begin testing ok( US::Currency->does('Comparable'), '... US::Currency does Comparable' ); ok( US::Currency->does('Eq'), '... US::Currency does Eq' ); ok( US::Currency->does('Printable'), '... US::Currency does Printable' ); my $hundred = US::Currency->new( amount => 100.00 ); isa_ok( $hundred, 'US::Currency' ); ok( $hundred->DOES("US::Currency"), "UNIVERSAL::DOES for class" ); ok( $hundred->DOES("Comparable"), "UNIVERSAL::DOES for role" ); can_ok( $hundred, 'amount' ); is( $hundred->amount, 100, '... got the right amount' ); can_ok( $hundred, 'to_string' ); is( $hundred->to_string, '$100.00 USD', '... got the right stringified value' ); ok( $hundred->does('Comparable'), '... US::Currency does Comparable' ); ok( $hundred->does('Eq'), '... US::Currency does Eq' ); ok( $hundred->does('Printable'), '... US::Currency does Printable' ); my $fifty = US::Currency->new( amount => 50.00 ); isa_ok( $fifty, 'US::Currency' ); can_ok( $fifty, 'amount' ); is( $fifty->amount, 50, '... got the right amount' ); can_ok( $fifty, 'to_string' ); is( $fifty->to_string, '$50.00 USD', '... got the right stringified value' ); ok( $hundred->greater_than($fifty), '... 100 gt 50' ); ok( $hundred->greater_than_or_equal_to($fifty), '... 100 ge 50' ); ok( !$hundred->less_than($fifty), '... !100 lt 50' ); ok( !$hundred->less_than_or_equal_to($fifty), '... !100 le 50' ); ok( !$hundred->equal_to($fifty), '... !100 eq 50' ); ok( $hundred->not_equal_to($fifty), '... 100 ne 50' ); ok( !$fifty->greater_than($hundred), '... !50 gt 100' ); ok( !$fifty->greater_than_or_equal_to($hundred), '... !50 ge 100' ); ok( $fifty->less_than($hundred), '... 50 lt 100' ); ok( $fifty->less_than_or_equal_to($hundred), '... 50 le 100' ); ok( !$fifty->equal_to($hundred), '... !50 eq 100' ); ok( $fifty->not_equal_to($hundred), '... 50 ne 100' ); ok( !$fifty->greater_than($fifty), '... !50 gt 50' ); ok( $fifty->greater_than_or_equal_to($fifty), '... !50 ge 50' ); ok( !$fifty->less_than($fifty), '... 50 lt 50' ); ok( $fifty->less_than_or_equal_to($fifty), '... 50 le 50' ); ok( $fifty->equal_to($fifty), '... 50 eq 50' ); ok( !$fifty->not_equal_to($fifty), '... !50 ne 50' ); ## ... check some meta-stuff # Eq my $eq_meta = Eq->meta; isa_ok( $eq_meta, 'Moose::Meta::Role' ); ok( $eq_meta->has_method('not_equal_to'), '... Eq has_method not_equal_to' ); ok( $eq_meta->requires_method('equal_to'), '... Eq requires_method not_equal_to' ); # Comparable my $comparable_meta = Comparable->meta; isa_ok( $comparable_meta, 'Moose::Meta::Role' ); ok( $comparable_meta->does_role('Eq'), '... Comparable does Eq' ); foreach my $method_name ( qw( equal_to not_equal_to greater_than greater_than_or_equal_to less_than less_than_or_equal_to ) ) { ok( $comparable_meta->has_method($method_name), '... Comparable has_method ' . $method_name ); } ok( $comparable_meta->requires_method('compare'), '... Comparable requires_method compare' ); # Printable my $printable_meta = Printable->meta; isa_ok( $printable_meta, 'Moose::Meta::Role' ); ok( $printable_meta->requires_method('to_string'), '... Printable requires_method to_string' ); # US::Currency my $currency_meta = US::Currency->meta; isa_ok( $currency_meta, 'Moose::Meta::Class' ); ok( $currency_meta->does_role('Comparable'), '... US::Currency does Comparable' ); ok( $currency_meta->does_role('Eq'), '... US::Currency does Eq' ); ok( $currency_meta->does_role('Printable'), '... US::Currency does Printable' ); foreach my $method_name ( qw( amount equal_to not_equal_to compare greater_than greater_than_or_equal_to less_than less_than_or_equal_to to_string ) ) { ok( $currency_meta->has_method($method_name), '... US::Currency has_method ' . $method_name ); } =end testing =head1 AUTHOR Moose is maintained by the Moose Cabal, along with the help of many contributors. See L and L for details. =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2013 by Infinity Interactive, Inc.. This is free software; you can redistribute it and/or modify it under the same terms as the Perl 5 programming language system itself. =cut Bool000755000767000024 012200352345 22016 5ustar00etherstaff000000000000Moose-2.1005/lib/Moose/Meta/Method/Accessor/Nativenot.pm100644000767000024 72012200352345 23273 0ustar00etherstaff000000000000Moose-2.1005/lib/Moose/Meta/Method/Accessor/Native/Boolpackage Moose::Meta::Method::Accessor::Native::Bool::not; BEGIN { $Moose::Meta::Method::Accessor::Native::Bool::not::AUTHORITY = 'cpan:STEVAN'; } { $Moose::Meta::Method::Accessor::Native::Bool::not::VERSION = '2.1005'; } use strict; use warnings; use Moose::Role; with 'Moose::Meta::Method::Accessor::Native::Reader'; sub _maximum_arguments { 0 } sub _return_value { my $self = shift; my ($slot_access) = @_; return '!' . $slot_access; } 1; set.pm100644000767000024 103712200352345 23310 0ustar00etherstaff000000000000Moose-2.1005/lib/Moose/Meta/Method/Accessor/Native/Boolpackage Moose::Meta::Method::Accessor::Native::Bool::set; BEGIN { $Moose::Meta::Method::Accessor::Native::Bool::set::AUTHORITY = 'cpan:STEVAN'; } { $Moose::Meta::Method::Accessor::Native::Bool::set::VERSION = '2.1005'; } use strict; use warnings; use Moose::Role; with 'Moose::Meta::Method::Accessor::Native::Writer'; sub _maximum_arguments { 0 } sub _potential_value { 1 } sub _inline_optimized_set_new_value { my $self = shift; my ($inv, $new, $slot_access) = @_; return $slot_access . ' = 1;'; } no Moose::Role; 1; get.pm100644000767000024 150412200352345 23263 0ustar00etherstaff000000000000Moose-2.1005/lib/Moose/Meta/Method/Accessor/Native/Hashpackage Moose::Meta::Method::Accessor::Native::Hash::get; BEGIN { $Moose::Meta::Method::Accessor::Native::Hash::get::AUTHORITY = 'cpan:STEVAN'; } { $Moose::Meta::Method::Accessor::Native::Hash::get::VERSION = '2.1005'; } use strict; use warnings; use Scalar::Util qw( looks_like_number ); use Moose::Role; with 'Moose::Meta::Method::Accessor::Native::Reader', 'Moose::Meta::Method::Accessor::Native::Hash'; sub _minimum_arguments { 1 } sub _inline_check_arguments { my $self = shift; return ( 'for (@_) {', $self->_inline_check_var_is_valid_key('$_'), '}', ); } sub _return_value { my $self = shift; my ($slot_access) = @_; return '@_ > 1 ' . '? @{ (' . $slot_access . ') }{@_} ' . ': ' . $slot_access . '->{$_[0]}'; } no Moose::Role; 1; set.pm100644000767000024 507112200352345 23302 0ustar00etherstaff000000000000Moose-2.1005/lib/Moose/Meta/Method/Accessor/Native/Hashpackage Moose::Meta::Method::Accessor::Native::Hash::set; BEGIN { $Moose::Meta::Method::Accessor::Native::Hash::set::AUTHORITY = 'cpan:STEVAN'; } { $Moose::Meta::Method::Accessor::Native::Hash::set::VERSION = '2.1005'; } use strict; use warnings; use List::MoreUtils (); use Scalar::Util qw( looks_like_number ); use Moose::Role; with 'Moose::Meta::Method::Accessor::Native::Hash::Writer'; sub _minimum_arguments { 2 } sub _maximum_arguments { undef } around _inline_check_argument_count => sub { my $orig = shift; my $self = shift; return ( $self->$orig(@_), 'if (@_ % 2) {', $self->_inline_throw_error( sprintf( '"You must pass an even number of arguments to %s"', $self->delegate_to_method, ), ) . ';', '}', ); }; sub _inline_process_arguments { my $self = shift; return ( 'my @keys_idx = grep { ! ($_ % 2) } 0..$#_;', 'my @values_idx = grep { $_ % 2 } 0..$#_;', ); } sub _inline_check_arguments { my $self = shift; return ( 'for (@keys_idx) {', 'if (!defined($_[$_])) {', $self->_inline_throw_error( sprintf( '"Hash keys passed to %s must be defined"', $self->delegate_to_method, ), ) . ';', '}', '}', ); } sub _adds_members { 1 } # We need to override this because while @_ can be written to, we cannot write # directly to $_[1]. sub _inline_coerce_new_values { my $self = shift; return unless $self->associated_attribute->should_coerce; return unless $self->_tc_member_type_can_coerce; # Is there a simpler way to do this? return ( 'my $iter = List::MoreUtils::natatime(2, @_);', '@_ = ();', 'while (my ($key, $val) = $iter->()) {', 'push @_, $key, $member_coercion->($val);', '}', ); }; sub _potential_value { my $self = shift; my ($slot_access) = @_; return '{ %{ (' . $slot_access . ') }, @_ }'; } sub _new_members { '@_[ @values_idx ]' } sub _inline_optimized_set_new_value { my $self = shift; my ($inv, $new, $slot_access) = @_; return '@{ (' . $slot_access . ') }{ @_[@keys_idx] } = @_[@values_idx];'; } sub _return_value { my $self = shift; my ($slot_access) = @_; return 'wantarray ' . '? @{ (' . $slot_access . ') }{ @_[@keys_idx] } ' . ': ' . $slot_access . '->{ $_[$keys_idx[0]] }'; } no Moose::Role; 1; role_attr_methods_original_package.t100644000767000024 155712200352345 24241 0ustar00etherstaff000000000000Moose-2.1005/t/todo_testsuse strict; use warnings; use Test::More 0.88; { package Some::Role; use Moose::Role; has 'thing' => ( is => 'ro', ); sub foo { 42 } } { package Some::Class; use Moose; with 'Some::Role'; } my $attr = Some::Class->meta()->get_attribute('thing'); # See RT #84563 for my $method ( @{ $attr->associated_methods() } ) { TODO: { local $TODO = q{Methods generated from role-provided attributes don't know their original package}; is( $method->original_package_name(), 'Some::Role', 'original_package_name for methods generated from role attribute should match the role' ); } } is( Some::Class->meta()->get_method('foo')->original_package_name(), 'Some::Role', 'original_package_name for methods from role should match the role' ); done_testing(); util_type_constraints_export.t100644000767000024 115012200352345 24440 0ustar00etherstaff000000000000Moose-2.1005/t/type_constraints#!/usr/bin/perl use strict; use warnings; use Test::More; { package Foo; use Moose::Util::TypeConstraints; eval { type MyRef => where { ref($_) }; }; ::ok( !$@, '... successfully exported &type to Foo package' ); eval { subtype MyArrayRef => as MyRef => where { ref($_) eq 'ARRAY' }; }; ::ok( !$@, '... successfully exported &subtype to Foo package' ); Moose::Util::TypeConstraints->export_type_constraints_as_functions(); ::ok( MyRef( {} ), '... Ref worked correctly' ); ::ok( MyArrayRef( [] ), '... ArrayRef worked correctly' ); } done_testing; basics_point_attributesandsubclassing.t100644000767000024 1254712200352345 24314 0ustar00etherstaff000000000000Moose-2.1005/t/recipes#!/usr/bin/perl -w use strict; use Test::More 'no_plan'; use Test::Fatal; $| = 1; # =begin testing SETUP { package Point; use Moose; has 'x' => (isa => 'Int', is => 'rw', required => 1); has 'y' => (isa => 'Int', is => 'rw', required => 1); sub clear { my $self = shift; $self->x(0); $self->y(0); } package Point3D; use Moose; extends 'Point'; has 'z' => (isa => 'Int', is => 'rw', required => 1); after 'clear' => sub { my $self = shift; $self->z(0); }; package main; # hash or hashrefs are ok for the constructor my $point1 = Point->new(x => 5, y => 7); my $point2 = Point->new({x => 5, y => 7}); my $point3d = Point3D->new(x => 5, y => 42, z => -5); } # =begin testing { my $point = Point->new( x => 1, y => 2 ); isa_ok( $point, 'Point' ); isa_ok( $point, 'Moose::Object' ); is( $point->x, 1, '... got the right value for x' ); is( $point->y, 2, '... got the right value for y' ); $point->y(10); is( $point->y, 10, '... got the right (changed) value for y' ); isnt( exception { $point->y('Foo'); }, undef, '... cannot assign a non-Int to y' ); isnt( exception { Point->new(); }, undef, '... must provide required attributes to new' ); $point->clear(); is( $point->x, 0, '... got the right (cleared) value for x' ); is( $point->y, 0, '... got the right (cleared) value for y' ); # check the type constraints on the constructor is( exception { Point->new( x => 0, y => 0 ); }, undef, '... can assign a 0 to x and y' ); isnt( exception { Point->new( x => 10, y => 'Foo' ); }, undef, '... cannot assign a non-Int to y' ); isnt( exception { Point->new( x => 'Foo', y => 10 ); }, undef, '... cannot assign a non-Int to x' ); # Point3D my $point3d = Point3D->new( { x => 10, y => 15, z => 3 } ); isa_ok( $point3d, 'Point3D' ); isa_ok( $point3d, 'Point' ); isa_ok( $point3d, 'Moose::Object' ); is( $point3d->x, 10, '... got the right value for x' ); is( $point3d->y, 15, '... got the right value for y' ); is( $point3d->{'z'}, 3, '... got the right value for z' ); $point3d->clear(); is( $point3d->x, 0, '... got the right (cleared) value for x' ); is( $point3d->y, 0, '... got the right (cleared) value for y' ); is( $point3d->z, 0, '... got the right (cleared) value for z' ); isnt( exception { Point3D->new( x => 10, y => 'Foo', z => 3 ); }, undef, '... cannot assign a non-Int to y' ); isnt( exception { Point3D->new( x => 'Foo', y => 10, z => 3 ); }, undef, '... cannot assign a non-Int to x' ); isnt( exception { Point3D->new( x => 0, y => 10, z => 'Bar' ); }, undef, '... cannot assign a non-Int to z' ); isnt( exception { Point3D->new( x => 10, y => 3 ); }, undef, '... z is a required attribute for Point3D' ); # test some class introspection can_ok( 'Point', 'meta' ); isa_ok( Point->meta, 'Moose::Meta::Class' ); can_ok( 'Point3D', 'meta' ); isa_ok( Point3D->meta, 'Moose::Meta::Class' ); isnt( Point->meta, Point3D->meta, '... they are different metaclasses as well' ); # poke at Point is_deeply( [ Point->meta->superclasses ], ['Moose::Object'], '... Point got the automagic base class' ); my @Point_methods = qw(meta x y clear); my @Point_attrs = ( 'x', 'y' ); is_deeply( [ sort @Point_methods ], [ sort Point->meta->get_method_list() ], '... we match the method list for Point' ); is_deeply( [ sort @Point_attrs ], [ sort Point->meta->get_attribute_list() ], '... we match the attribute list for Point' ); foreach my $method (@Point_methods) { ok( Point->meta->has_method($method), '... Point has the method "' . $method . '"' ); } foreach my $attr_name (@Point_attrs) { ok( Point->meta->has_attribute($attr_name), '... Point has the attribute "' . $attr_name . '"' ); my $attr = Point->meta->get_attribute($attr_name); ok( $attr->has_type_constraint, '... Attribute ' . $attr_name . ' has a type constraint' ); isa_ok( $attr->type_constraint, 'Moose::Meta::TypeConstraint' ); is( $attr->type_constraint->name, 'Int', '... Attribute ' . $attr_name . ' has an Int type constraint' ); } # poke at Point3D is_deeply( [ Point3D->meta->superclasses ], ['Point'], '... Point3D gets the parent given to it' ); my @Point3D_methods = qw( meta z clear ); my @Point3D_attrs = ('z'); is_deeply( [ sort @Point3D_methods ], [ sort Point3D->meta->get_method_list() ], '... we match the method list for Point3D' ); is_deeply( [ sort @Point3D_attrs ], [ sort Point3D->meta->get_attribute_list() ], '... we match the attribute list for Point3D' ); foreach my $method (@Point3D_methods) { ok( Point3D->meta->has_method($method), '... Point3D has the method "' . $method . '"' ); } foreach my $attr_name (@Point3D_attrs) { ok( Point3D->meta->has_attribute($attr_name), '... Point3D has the attribute "' . $attr_name . '"' ); my $attr = Point3D->meta->get_attribute($attr_name); ok( $attr->has_type_constraint, '... Attribute ' . $attr_name . ' has a type constraint' ); isa_ok( $attr->type_constraint, 'Moose::Meta::TypeConstraint' ); is( $attr->type_constraint->name, 'Int', '... Attribute ' . $attr_name . ' has an Int type constraint' ); } } 1; legacy_debugging_baseclassreplacement.t100644000767000024 171112200352345 24136 0ustar00etherstaff000000000000Moose-2.1005/t/recipes#!/usr/bin/perl -w use strict; use Test::More 'no_plan'; use Test::Fatal; $| = 1; # =begin testing SETUP { package MyApp::Base; use Moose; extends 'Moose::Object'; before 'new' => sub { warn "Making a new " . $_[0] }; no Moose; package MyApp::UseMyBase; use Moose (); use Moose::Exporter; Moose::Exporter->setup_import_methods( also => 'Moose' ); sub init_meta { shift; return Moose->init_meta( @_, base_class => 'MyApp::Base' ); } } # =begin testing SETUP use Test::Requires { 'Test::Output' => '0', }; # =begin testing { { package Foo; MyApp::UseMyBase->import; has( 'size' => ( is => 'rw' ) ); } ok( Foo->isa('MyApp::Base'), 'Foo isa MyApp::Base' ); ok( Foo->can('size'), 'Foo has a size method' ); my $foo; stderr_like( sub { $foo = Foo->new( size => 2 ) }, qr/^Making a new Foo/, 'got expected warning when calling Foo->new' ); is( $foo->size(), 2, '$foo->size is 2' ); } 1; Extending000755000767000024 012200352345 17520 5ustar00etherstaff000000000000Moose-2.1005/lib/Moose/CookbookExtensionOverview.pod100644000767000024 3247712200352345 24124 0ustar00etherstaff000000000000Moose-2.1005/lib/Moose/Cookbook/Extendingpackage Moose::Cookbook::Extending::ExtensionOverview; # ABSTRACT: Moose extension overview __END__ =pod =head1 NAME Moose::Cookbook::Extending::ExtensionOverview - Moose extension overview =head1 VERSION version 2.1005 =head1 DESCRIPTION Moose provides several ways in which extensions can hook into Moose and change its behavior. Moose also has a lot of behavior that can be changed. This recipe will provide an overview of each extension method and give you some recommendations on what tools to use. If you haven't yet read the recipes on metaclasses, go read those first. You can't write Moose extensions without understanding the metaclasses, and those recipes also demonstrate some basic extension mechanisms, such as metaclass subclasses and traits. =head2 Playing Nice With Others One of the goals of this overview is to help you build extensions that cooperate well with other extensions. This is especially important if you plan to release your extension to CPAN. Moose comes with several modules that exist to help your write cooperative extensions. These are L and L. By using these two modules, you will ensure that your extension works with both the Moose core features and any other CPAN extension using those modules. =head1 PARTS OF Moose YOU CAN EXTEND The types of things you might want to do in Moose extensions fall into a few broad categories. =head2 Metaclass Extensions One way of extending Moose is by extending one or more Moose metaclasses. For example, in L we saw a metaclass role that added a C
attribute to the metaclass. If you were writing an ORM, this would be a logical extension. Many of the Moose extensions on CPAN work by providing an attribute metaclass role. For example, the L module provides an attribute metaclass trait that lets you specify aliases to install for methods and attribute accessors. A metaclass extension can be packaged as a role/trait or a subclass. If you can, we recommend using traits instead of subclasses, since it's much easier to combine disparate traits than it is to combine a bunch of subclasses. When your extensions are implemented as roles, you can apply them with the L module. =head2 Providing Sugar Functions As part of a metaclass extension, you may also want to provide some sugar functions, just like L does. Moose provides a helper module called L that makes this much simpler. We will be use L in several of the extension recipes. =head2 Object Class Extensions Another common Moose extension technique is to change the default object class's behavior. As with metaclass extensions, this can be done with a role/trait or with a subclass. For example, L extension applies a trait that makes the constructor reject arguments which don't match its attributes. Object class extensions often include metaclass extensions as well. In particular, if you want your object extension to work when a class is made immutable, you may need to modify the behavior of some or all of the L, L, and L objects. The L module lets you apply roles to the base object class, as well as the meta classes just mentioned. =head2 Providing a Role Some extensions come in the form of a role for you to consume. The L extension is a great example of this. In fact, despite the C name, it does not actually change anything about Moose's behavior. Instead, it is just a role that an object which wants to be pluggable can consume. If you are implementing this sort of extension, you don't need to do anything special. You simply create a role and document that it should be used via the normal C sugar: package MyApp::User; use Moose; with 'My::Role'; Don't use "MooseX" in the name for such packages. =head2 New Types Another common Moose extension is a new type for the Moose type system. In this case, you simply create a type in your module. When people load your module, the type is created, and they can refer to it by name after that. The L and L distributions are two good examples of how this works. These both build on top of the L extension. =head1 ROLES VS TRAITS VS SUBCLASSES It is important to understand that B. A trait is simply a role applied to a instance. The only thing that may distinguish the two is that a trait can be packaged in a way that lets Moose resolve a short name to a class name. In other words, with a trait, the caller can refer to it by a short name like "Big", and Moose will resolve it to a class like C. See L and L for examples of traits in action. In particular, both of these recipes demonstrate the trait resolution mechanism. Implementing an extension as a (set of) metaclass or base object role(s) will make your extension more cooperative. It is hard for an end-user to effectively combine together multiple metaclass subclasses, but it is very easy to combine roles. =head1 USING YOUR EXTENSION There are a number of ways in which an extension can be applied. In some cases you can provide multiple ways of consuming your extension. =head2 Extensions as Metaclass Traits If your extension is available as a trait, you can ask end users to simply specify it in a list of traits. Currently, this only works for (class) metaclass and attribute metaclass traits: use Moose -traits => [ 'Big', 'Blue' ]; has 'animal' => ( traits => [ 'Big', 'Blue' ], ... ); If your extension applies to any other metaclass, or the object base class, you cannot use the trait mechanism. The benefit of the trait mechanism is that is very easy to see where a trait is applied in the code, and consumers have fine-grained control over what the trait applies to. This is especially true for attribute traits, where you can apply the trait to just one attribute in a class. =head2 Extensions as Metaclass (and Base Object) Roles Implementing your extensions as metaclass roles makes your extensions easy to apply, and cooperative with other role-based extensions for metaclasses. Just as with a subclass, you will probably want to package your extensions for consumption with a single module that uses L. However, in this case, you will use L to apply all of your roles. The advantage of using this module is that I. This means that your extension is cooperative I, and consumers of your extension can easily use it with other role-based extensions. Most uses of L can be handled by L directly; see the L docs. package MooseX::Embiggen; use Moose::Exporter; use MooseX::Embiggen::Role::Meta::Class; use MooseX::Embiggen::Role::Meta::Attribute; use MooseX::Embiggen::Role::Meta::Method::Constructor; use MooseX::Embiggen::Role::Object; Moose::Exporter->setup_import_methods( class_metaroles => { class => ['MooseX::Embiggen::Role::Meta::Class'], attribute => ['MooseX::Embiggen::Role::Meta::Attribute'], constructor => ['MooseX::Embiggen::Role::Meta::Method::Constructor'], }, base_class_roles => ['MooseX::Embiggen::Role::Object'], ); As you can see from this example, you can use L to apply roles to any metaclass, as well as the base object class. If some other extension has already applied its own roles, they will be preserved when your extension applies its roles, and vice versa. =head2 Providing Sugar With L, you can also export your own sugar functions: package MooseX::Embiggen; use Moose::Exporter; Moose::Exporter->setup_import_methods( with_meta => ['embiggen'], class_metaroles => { class => ['MooseX::Embiggen::Role::Meta::Class'], }, ); sub embiggen { my $meta = shift; $meta->embiggen(@_); } And then the consumer of your extension can use your C sub: package Consumer; use Moose; use MooseX::Embiggen; extends 'Thing'; embiggen ...; This can be combined with metaclass and base class roles quite easily. =head2 More advanced extensions Providing your extension simply as a set of traits that gets applied to the appropriate metaobjects is easy, but sometimes not sufficient. For instance, sometimes you need to supply not just a base object role, but an actual base object class (due to needing to interact with existing systems that only provide a base class). To write extensions like this, you will need to provide a custom C method in your exporter. For instance: package MooseX::Embiggen; use Moose::Exporter; my ($import, $unimport, $init_meta) = Moose::Exporter->build_import_methods( install => ['import', 'unimport'], with_meta => ['embiggen'], class_metaroles => { class => ['MooseX::Embiggen::Role::Meta::Class'], }, ); sub embiggen { my $meta = shift; $meta->embiggen(@_); } sub init_meta { my $package = shift; my %options = @_; if (my $meta = Class::MOP::class_of($options{for_class})) { if ($meta->isa('Class::MOP::Class')) { my @supers = $meta->superclasses; $meta->superclasses('MooseX::Embiggen::Base::Class') if @supers == 1 && $supers[0] eq 'Moose::Object'; } } $package->$init_meta(%options); } In the previous examples, C was generated for you, but here you must override it in order to add additional functionality. Some differences to note: =over 4 =item C instead of C C simply returns the C, C, and C methods, rather than installing them under the appropriate names. This way, you can write your own methods which wrap the functionality provided by L. The C sub also takes an additional C parameter, which tells it to just go ahead and install these methods (since we don't need to modify them). =item C Next, we must write our C wrapper. The important things to remember are that it is called as a method, and that C<%options> needs to be passed through to the existing implementation. We call the base implementation by using the C<$init_meta> subroutine reference that was returned by C earlier. =item Additional implementation This extension sets a different default base object class. To do so, it first checks to see if it's being applied to a class, and then checks to see if L is that class's only superclass, and if so, replaces that with the superclass that this extension requires. Note that two extensions that do this same thing will not work together properly (the second extension to be loaded won't see L as the base object, since it has already been overridden). This is why using a base object role is recommended for the general case. This C also works defensively, by only applying its functionality if a metaclass already exists. This makes sure it doesn't break with legacy extensions which override the metaclass directly (and so must be the first extension to initialize the metaclass). This is likely not necessary, since almost no extensions work this way anymore, but just provides an additional level of protection. The common case of C is not affected regardless. =back This is just one example of what can be done with a custom C method. It can also be used for preventing an extension from being applied to a role, doing other kinds of validation on the class being applied to, or pretty much anything that would otherwise be done in an C method. =head1 LEGACY EXTENSION MECHANISMS Before the existence of L and L, there were a number of other ways to extend Moose. In general, these methods were less cooperative, and only worked well with a single extension. These methods include L, L (which uses L under the hood), and various hacks to do what L does. Please do not use these for your own extensions. Note that if you write a cooperative extension, it should cooperate with older extensions, though older extensions generally do not cooperate with each other. =head1 CONCLUSION If you can write your extension as one or more metaclass and base object roles, please consider doing so. Make sure to read the docs for L and L as well. =head1 AUTHOR Moose is maintained by the Moose Cabal, along with the help of many contributors. See L and L for details. =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2013 by Infinity Interactive, Inc.. This is free software; you can redistribute it and/or modify it under the same terms as the Perl 5 programming language system itself. =cut Legacy000755000767000024 012200352345 16777 5ustar00etherstaff000000000000Moose-2.1005/lib/Moose/CookbookTable_ClassMetaclass.pod100644000767000024 503312200352345 23655 0ustar00etherstaff000000000000Moose-2.1005/lib/Moose/Cookbook/Legacypackage Moose::Cookbook::Meta::Table_ClassMetaclass; # ABSTRACT: Adding a "table" attribute to the metaclass __END__ =pod =head1 NAME Moose::Cookbook::Meta::Table_ClassMetaclass - Adding a "table" attribute to the metaclass =head1 VERSION version 2.1005 =head1 SYNOPSIS package MyApp::Meta::Class; use Moose; extends 'Moose::Meta::Class'; has table => ( is => 'rw', isa => 'Str', ); =head1 DESCRIPTION B In this recipe, we'll create a new metaclass which has a "table" attribute. This metaclass is for classes associated with a DBMS table, as one might do for an ORM. In this example, the table name is just a string, but in a real ORM the table might be an object describing the table. =head1 THE METACLASS This really is as simple as the recipe L shows. The trick is getting your classes to use this metaclass, and providing some sort of sugar for declaring the table. This is covered in L, which shows how to make a module like C itself, with sugar like C. =head2 Using this Metaclass in Practice Accessing this new C
attribute is quite simple. Given a class named C, we could simply write the following: my $table = MyApp::User->meta->table; As long as C has arranged to use C as its metaclass, this method call just works. If we want to be more careful, we can check the metaclass's class: $table = MyApp::User->meta->table if MyApp::User->meta->isa('MyApp::Meta::Class'); =head1 CONCLUSION Creating custom metaclass is trivial. Using it is a little harder, and is covered in other recipes. We will also talk about applying traits to a class metaclass, which is a more flexible and cooperative implementation. =head1 SEE ALSO L - The "table" attribute implemented as a metaclass trait L - Acting like Moose.pm and providing sugar Moose-style =head1 AUTHOR Moose is maintained by the Moose Cabal, along with the help of many contributors. See L and L for details. =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2013 by Infinity Interactive, Inc.. This is free software; you can redistribute it and/or modify it under the same terms as the Perl 5 programming language system itself. =cut Labeled_AttributeTrait.pod100644000767000024 2065512200352345 23734 0ustar00etherstaff000000000000Moose-2.1005/lib/Moose/Cookbook/Metapackage Moose::Cookbook::Meta::Labeled_AttributeTrait; # ABSTRACT: Labels implemented via attribute traits __END__ =pod =head1 NAME Moose::Cookbook::Meta::Labeled_AttributeTrait - Labels implemented via attribute traits =head1 VERSION version 2.1005 =head1 SYNOPSIS package MyApp::Meta::Attribute::Trait::Labeled; use Moose::Role; Moose::Util::meta_attribute_alias('Labeled'); has label => ( is => 'rw', isa => 'Str', predicate => 'has_label', ); package MyApp::Website; use Moose; has url => ( traits => [qw/Labeled/], is => 'rw', isa => 'Str', label => "The site's URL", ); has name => ( is => 'rw', isa => 'Str', ); sub dump { my $self = shift; my $meta = $self->meta; my $dump = ''; for my $attribute ( map { $meta->get_attribute($_) } sort $meta->get_attribute_list ) { if ( $attribute->does('MyApp::Meta::Attribute::Trait::Labeled') && $attribute->has_label ) { $dump .= $attribute->label; } else { $dump .= $attribute->name; } my $reader = $attribute->get_read_method; $dump .= ": " . $self->$reader . "\n"; } return $dump; } package main; my $app = MyApp::Website->new( url => "http://google.com", name => "Google" ); =head1 SUMMARY In this recipe, we begin to delve into the wonder of meta-programming. Some readers may scoff and claim that this is the arena of only the most twisted Moose developers. Absolutely not! Any sufficiently twisted developer can benefit greatly from going more meta. Our goal is to allow each attribute to have a human-readable "label" attached to it. Such labels would be used when showing data to an end user. In this recipe we label the C attribute with "The site's URL" and create a simple method showing how to use that label. =head1 META-ATTRIBUTE OBJECTS All the attributes of a Moose-based object are actually objects themselves. These objects have methods and attributes. Let's look at a concrete example. has 'x' => ( isa => 'Int', is => 'ro' ); has 'y' => ( isa => 'Int', is => 'rw' ); Internally, the metaclass for C has two L objects. There are several methods for getting meta-attributes out of a metaclass, one of which is C. This method is called on the metaclass object. The C method returns a list of attribute names. You can then use C to get the L object itself. Once you have this meta-attribute object, you can call methods on it like this: print $point->meta->get_attribute('x')->type_constraint; => Int To add a label to our attributes there are two steps. First, we need a new attribute metaclass trait that can store a label for an attribute. Second, we need to apply that trait to our attributes. =head1 TRAITS Roles that apply to metaclasses have a special name: traits. Don't let the change in nomenclature fool you, B. L allows you to pass a C parameter for an attribute. This parameter takes a list of trait names which are composed into an anonymous metaclass, and that anonymous metaclass is used for the attribute. Yes, we still have lots of metaclasses in the background, but they're managed by Moose for you. Traits can do anything roles can do. They can add or refine attributes, wrap methods, provide more methods, define an interface, etc. The only difference is that you're now changing the attribute metaclass instead of a user-level class. =head1 DISSECTION We start by creating a package for our trait. package MyApp::Meta::Attribute::Trait::Labeled; use Moose::Role; has label => ( is => 'rw', isa => 'Str', predicate => 'has_label', ); You can see that a trait is just a L. In this case, our role contains a single attribute, C