Build.PL000644000765000024 351212245117716 13235 0ustar00gfxstaff000000000000Mouse-2.1.0# ========================================================================= # THIS FILE IS AUTOMATICALLY GENERATED BY MINILLA. # DO NOT EDIT DIRECTLY. # ========================================================================= use 5.008_001; use strict; use warnings; use utf8; use builder::MyBuilder; use File::Basename; use File::Spec; use CPAN::Meta; use CPAN::Meta::Prereqs; my %args = ( license => 'perl', dynamic_config => 0, configure_requires => { 'Module::Build' => 0.38, }, name => 'Mouse', module_name => 'Mouse', allow_pureperl => 1, script_files => [glob('script/*'), glob('bin/*')], c_source => [qw()], PL_files => {}, test_files => ((-d '.git' || $ENV{RELEASE_TESTING}) && -d 'xt') ? 't/ xt/' : 't/', recursive_test_files => 1, ); if (-d 'share') { $args{share_dir} = 'share'; } my $builder = builder::MyBuilder->subclass( class => 'MyBuilder', code => q{ sub ACTION_distmeta { die "Do not run distmeta. Install Minilla and `minil install` instead.\n"; } sub ACTION_installdeps { die "Do not run installdeps. Run `cpanm --installdeps .` instead.\n"; } } )->new(%args); $builder->create_build_script(); my $mbmeta = CPAN::Meta->load_file('MYMETA.json'); my $meta = CPAN::Meta->load_file('META.json'); my $prereqs_hash = CPAN::Meta::Prereqs->new( $meta->prereqs )->with_merged_prereqs( CPAN::Meta::Prereqs->new($mbmeta->prereqs) )->as_string_hash; my $mymeta = CPAN::Meta->new( { %{$meta->as_struct}, prereqs => $prereqs_hash } ); print "Merging cpanfile prereqs to MYMETA.yml\n"; $mymeta->save('MYMETA.yml', { version => 1.4 }); print "Merging cpanfile prereqs to MYMETA.json\n"; $mymeta->save('MYMETA.json', { version => 2 }); Changes000644000765000024 10443212245117717 13300 0ustar00gfxstaff000000000000Mouse-2.1.0Revision history for Mouse 2.1.0 2013-11-26T13:15:54Z - Dropped 5.6.2 support - Migrated to Minilla 2.0.0 2013-11-06 09:15:00+0900 [BUG FIXES] - Merged the pull-request #13, which fixed an issue where the behavior of role method confliction was different from Moose. This change might affect your existing code so the major version has incremented. See t/030_roles/role_conflict_and_inheritance.t for details. 1.13 2013-10-10 00:09:35+0900 [BUG FIXES] - Fix for perl 5.19.4 (RT 88295) 1.12 2013-09-29 09:52:47+0900 [BUG FIXES] - Fix a memory leak related to triggers, which was introduced in 1.07 (issue#7) 1.11 2013-04-28 22:00:38 [TEST FIXES] - Ensure Try::Tiny is bundled 1.10 2013-04-26 10:53:40 [TEST FIXES] - Bundle Try::Tiny for tests 1.09 2013-04-25 14:03:13 [TEST FIXES] - Bundle Test::Fatal for tests 1.08 2013-04-24 16:20:53 [FEATURES] - Support PUREPERL_ONLY See the Lancaster Consensus: https://github.com/sjn/toolchain-site/blob/219db464af9b2f19b04fec05547ac10180a469f3/lancaster-consensus.md#specifying-pure-perl-builds 1.07 2013-04-24 08:47:17 [BUG FIXES] - Make trigger pass in the old value for Moose compatibility (PR#6 by schwern) [TEST FIXES] - Get perlcritic tests working for PC 1.118 (PR#6 by schwern) 1.06 2013-04-09 23:40:02 [TEST FIXES] - Resolve RT#84518 caused by hash randomization 1.05 2013-02-08 00:32:33 [BUG FIXES] - Fix a memory leak introduced by v1.04 (creaktive & aiyumi, pull-req #4) 1.04 2013-01-11 01:46:18 [FEATURES] - Implement $attr->default($instance) for compatibility with Moose 1.03 2013-01-11 01:10:38 [FEATURES] - Add maybe_type() from Moose::Util::TypeConstraints (schwern) 1.02 2012-08-27 10:27:21 [IMPROVEMENT] - performance improvement for v5.14.0 or grater (dex4er) 1.01 2012-08-24 09:03:29 [BUG FIXES] - fix circular dependency which was introduced in 1.00 (hanekomu++) 1.00 2012-08-23 20:50:46 This is 1.00 but has no significant change! [BUG FIXES] - Fix a problem which occured in a case where a role applied to an instance with AUTOLOAD. 0.99 2012-06-30 14:47:03 [BUG FIXES] - Resolve RT#73592 use of local $_ was buggy in older perls - Resolve RT#75093 warning about weak_ref 0.98 2012-06-30 14:02:26 [ANNOUNCE] - The repository has been moved to github https://github.com/gfx/p5-Mouse in order toto accept pull-requests easily! [BUG FIXES] - Resolve RT#75313 and RT#77227 ($@ issues) 0.97 2011-10-09 14:45:55 [TEST FIXES] - Fixes in 0.96 is broken 0.96 2011-10-09 14:34:39 [TEST FIXES] - Workaround for RT #71211 (made the failing test a TODO) 0.95 2011-10-07 13:41:31 [TEST FIXES] - Workaround for RT #71211 (maybe) 0.94 2011-10-03 17:07:57 [BUG FIXES] * Resolve #68351, tests produced deprecation warnings in 5.14 * Resolve #70518, a build problem in 5.15 * Resolve #70569, prototype mismatch warnings might happen in 5.8 0.93 2011-05-17 00:22:12 [BUG FIXES] * Make sure weak attributes remain weak when cloning (Moose 2.0007) 0.92 2011-4-14 23:37 [BUG FIXES] * Replace C++-style comments (//) with C89-style comments(/* */) (RT #67412) 0.91 2011-03-14 13:12:35 [CHANGES] * $type_constraint->check() accepts extra arguments for extensibility (requested by @lestrrat) 0.90 2011-02-21 10:48:58 [BUG FIXES] * Fix an abuse of a private Perl API, which changed at Perl 5.13.10 (Thanks to avar) [NEW FEATURES] * Support the DOES() method for Mouse::Object 0.89 2011-01-27 09:18:39 [BUG FIXES] * Disable foreign class warnings introduced at 0.71, which affects compatibility with Moose (and will re-introduce in more compatible way in the future) 0.88 2010-12-05 14:24:14 [BUG FIXES] * Workaround SL4A where mro.pm doesn't exist even if Perl >= 5.10.0 (reported by @hide_o_55) 0.87 2010-11-13 23:44:20 [BUG FIXES] * Fix packaging issues - META.yml was not updated (reported by @shohex) - `make realclean` should remove xshelper.h (patched by Ingy dot Net, and modified by gfx) [OTHERS] * Type coercion routines have been refactored; coercions are compiled on demand. 0.86 2010-11-12 20:12:53 [BUG FIXES] * Role application to instances cached anonymous classes in wrong way 0.85 2010-11-11 10:51:45 [BUG FIXES] * Fix an error message to be compatible with Moose's * Fix build problems 0.84 2010-11-10 14:31:20 * No feature changes * Fix tests not to depend on platforms 0.83 2010-11-08 11:40:25 [BUG FIXES] * 'Int' type constraint passed dualvars (e.g. $!) while Moose's doesn't 0.82 2010-11-05 18:12:28 [BUG FIXES] * Wrong name for a method in Mouse::Meta::TypeConstraint: s/is_a_subtype_of/is_a_type_of/ * $type_constraint->type_parameter didn't return the correct value if it's a subtype of paramterized type constraints 0.81 2010-10-28 21:49:40 [BUG FIXES] * Roles which attributes has no methods could affect cache invalidation 0.80 Wed Oct 6 00:15:49 2010 [BUG FIXES] * Resolve RT #61906 (Syohei Yoshida): A single 'accessor' did not define the method for the attribute 0.79 Tue Oct 5 19:26:11 2010 [BUG FIXES] * Fix a mis-use of aTHX_/pTHX_ in XS (Vincent Pit) 0.78 Tue Oct 5 15:27:13 2010 [BUG FIXES] * Resolve RT #61852 (Vincent Pit): Parametrized type constraints didn't call their "where" clause anymore. * Mouse::Object::DESTROY could fail to call DEMOLISHes in some cases (reported by @typester). 0.77 Wed Sep 29 21:35:11 2010 [BUG FIXES] * Fix tests failed against 5.6.2 * Combination of 'isa' and 'does' for has() sugar was incorrectly proccessed in Mouse::PurePerl. * Fix foreign class checking routines. Please update MouseX::Foreign. 0.76 Tue Sep 28 16:10:31 2010 [BUG FIXES] * Workaround 5.6.problems * Fix edge cases of handles => sub { ... } * Aoid warnigs on attribute cloning 0.75 Mon Sep 27 15:07:03 2010 [BUG FIXES] * Diamond inheritanc without C3 mro cauld cause problems in Mouse::XS 0.74 Sun Sep 26 11:46:29 2010 [BUG FIXES] * Workaround Test::Builder2 problem again. Loading Mouse before loading Test::Builder 2.00_01 could causes SEGV, so I ensure to load Test::Builder first. * Fix some compatibility issues on perl 5.6.2 0.73 Sat Sep 25 21:49:30 2010 [BUG FIXES] * Resolve RT #61613 (Brett) 0.72 Sat Sep 25 20:47:51 2010 [BUG FIXES] * Internal refatoring has removed a number of incompatibilities in Mouse::PurePerl. * Error messages from duck types are now compatible with Moose. 0.71 Fri Sep 24 19:51:04 2010 [CHANGES] * Inheritance from non-Mouse classes now produces warnings. Use MouseX::Foreign if you want this type of inheritance. * A new module Mouse::Meta::Role::Application has been added. It doesn not affect public APIs, but internals are radically changed. For users, using Mouse without roles should consume less memory. [BUG FIXES] * Meta class reinitialization caused by Mouse::Util::MetaRole did not work correctly 0.70 Fri Sep 17 19:07:02 2010 [BUG FIXES] * Delegations ignored method modifiers 0.69 Mon Sep 13 14:04:41 2010 [BUG FIXES] * Workaround a problem with Test::Builder 2.00_01, which could cause SEGV (the HEAD in the repository of tb2 is okay) 0.68 Sat Sep 11 16:24:42 2010 [CHANGES] * Remove an optional depenency, Data::Util. This is used to make method modifiers faster, but the effect is limited to 'before' and 'after' modifiers. Rather, D::U's modifiers are slightly different from the standalone version, and sometimes the difference caused problems. 0.67 Fri Sep 10 13:56:38 2010 [BUG FIXES] * Oops! Fix a mistake of removing neccesary denepdencies 0.66 Fri Sep 10 13:30:41 2010 [BUG FIXES] * Workaround older perl's bug that caused segv in throwing errors * Fix looks_like_number portability 0.65 Thu Sep 9 13:30:33 2010 [CHANGES] * An attribute in a subclass can now override the value of "is" (Moose 1.07 feature) * Remove long deprecated methods: _create_args(), compute_all_applicable_attributes(), and clone_instance() [BUG FIXES] * Fix tests that misused test functions. This problem was revealed by Test::Builder2 * Improve C++ compatibility in Mouse::XS 0.64 Mon Jul 26 20:48:13 2010 [BUG FIXES] * Build failure on 5.13.3 [CHANGES] * Illegal inheritance options for clone_and_inherit_options() is now a black list, not a white list (Moose 1.09 feature) * Remove long deprecated methods in Mouse::Meta::Attribute: clone_parent, get_parent_args, canonicalize_args, create 0.63 Tue Jul 20 19:26:30 2010 [CHANGES] * Resolve RT#59460: Test::Requires is not a required prerequisite unless release-testing... (Curtis Jewell) See also https://rt.cpan.org/Public/Bug/Display.html?id=59460 [FEATURES] * Add Mouse::Util::TypeConstraints::register_type_constraint() (Vincent Pit) See also https://rt.cpan.org/Public/Bug/Display.html?id=59539 0.62 Tue Jul 6 20:18:58 2010 [FEATURES] * Support MouseX::StrictConstructor (gfx) 0.61 Sat Jun 19 15:35:48 2010 [BUG FIXES] * Workaround the Perl_call_sv() problem again (gfx) * Update Module::Install to 0.99 for older versions of perls (gfx) 0.60 Wed Jun 9 19:43:55 2010 [CHANGES] * BUILDALL is now called by Mouse::Meta::Class::new_object, rather than by Mouse::Object::new. (Moose 1.05) [BUG FIXES] * Fix type constraint validation messages to not include the string 'failed' twice in the same sentence. (Moose 1.05) * Resolve RT #57975: The prefix "Exception caught" is no longer added to exceptions Mouse catches. (gfx) [OTHERS] * A difficult test (t/900_mouse_bugs/006_RT69939.t) will be skipped on some platforms. (gfx) 0.59 Tue May 18 16:29:57 2010 [CHANGES] * Improve error messages on $class->accessor() (gfx) 0.58 Sat May 8 11:18:17 2010 [BUG FIX] * Compliant with 5.12.0+ 0.57 Fri May 7 14:27:00 2010 [BUG FIX] * Resolve RT #57144: Fix problems in Perl_call_sv() again (gfx) 0.56 Thu Apr 29 11:15:45 2010 [BUG FIX] * Resolve RT#56837: Role application to instance with init_arg'd attributes caused problems (Sanko Robinson) 0.55 Wed Apr 21 13:27:13 2010 [BUG FIX] * Fix a bug that traits could cause panic/SEGV on threads (gfx) 0.54 Sat Apr 17 17:15:54 2010 [BUG FIX] * Resolve RT#56523: has with reader, writer, lazy and builder could not create a write-only accessor (Michael G Schwern) 0.53 Sun Apr 11 11:39:03 2010 [BUG FIX] * Mouse::Meta::Class could not clone objects with "required" attrs (gfx) 0.52 Sat Mar 27 15:38:52 2010 * Workaround Perl-RT#69939 (eval "use $module" in Perl_call_sv() may cause segmentation faults, http://rt.perl.org/rt3/Public/Bug/Display.html?id=69939) 0.51 Mon Mar 15 15:25:58 2010 SUMMARY [BUG FIXES] * Mouse::Object::DESTROY could cause SEGVs * Attribute triggers could cause panics * Integers > 2**32 were not groked as Int * Incorrect types, e.g. "Array[Int", was accepted * Metaclass compatibility was sometimes ignored [MOOSE COMPATIBILITY] * before/around/after accept regular expressions * has() becomes strict * the global destruction flag is passed to DEMOLISH methods * Delegations can be curried * Built-in type constraints have the same hierarchy as Moose's 0.50_09 Mon Mar 15 12:02:28 2010 * (re)fix RT #55048 to grok 2**46+0.5 as Int, but accept 2**46 as Int even on 32 bit environments; note that an Int is exactly what is matched to /^[+-]?[0-9]+$/, so 10e100 will not be groked as Int (gfx) 0.50_08 Thu Mar 11 19:28:58 2010 * Makefile.PL - Resolved #55419: Add Devel::PPPort to build_requires (gfx) * Mouse::Exporter - Turns on warnings FATAL => 'recursion' by default (gfx) * Mouse::Util::TypeConstraints - Change the type parser to check syntax (gfx) (Now it throws erros to "ArrayRef[]", "ArrayRef[Int", etc.) 0.50_07 Sun Mar 7 19:59:37 2010 * Mouse::Meta::Attribute - Fix a possible panic, caused by triggers, reported by Nobuo Danjou (gfx) 0.50_06 Tue Mar 2 18:35:12 2010 * Mouse::PurePerl - Fix an issue on metaclass compatibility again (gfx) - Fix more-than-32-bit-int progrem again (gfx) 0.50_05 Mon Mar 1 11:18:26 2010 * Mouse::Util::TypeConstraints - Mouse used an incorrect cast at the C-level which meant that its idea of numbers was different from that of Perl's (and Mouse's). Notably > 2**32 Integers on 32 bit systems didn't work, RT #55048 (AEvar). * Mouse::Meta::Classs - Fix an issue on metaclass compatibility (gfx) 0.50_04 Fri Feb 26 18:57:24 2010 * All - Warnings are less noisy, as shown by example/warns.pl (gfx) - Various optimization and refactoring (gfx) 0.50_03 Mon Feb 22 17:56:47 2010 * Mouse::Meta::Attribute - Catch up about Moose 0.84 about warnings (gfx) - If an attribute generates no accessors, it will be warned - If both 'isa' and 'does' are specified and 'isa' does not do 'does', then it will be warned * Mouse::Object - Fix a possible segv which is caused by destructors (gfx) * Mouse::Util::TypeConstraints - Implement the built-in type hierarchy (gfx) 0.50_02 Sat Feb 20 14:37:16 2010 * Mouse::Meta::Attribute - Implement argument currying for delegation (gfx) * Mouse::Meta::Method::Constructor - Implement strict constructors experimentally, which will warn unkown constructor arguments (gfx) 0.50_01 Sat Feb 13 16:39:48 2010 * Mouse - before/around/after now accept regexps (gfx) * Mouse::Object - Support the global destruction flag in DEMOLISH (gfx) * Mouse::Meta::Attribute - Attribute constructors now warn very noisily about unknown (or misspelled) arguments (gfx) 0.50 Mon Feb 8 13:43:19 2010 * Mouse::Tiny - Allow "use Mouse::Tiny VERSION" with a patch contributed by chocolateboy, RT #54383 (gfx) * Mouse::Util::MetaRole - Add Mouse::Util::MetaRole::apply_metaroles to catch up the latest Moose API for metaroles (gfx) 0.49 Tue Feb 2 12:58:45 2010 * MouseAccessor.xs - Fix RT #54203 that writers might return undef in setting values reported by chocolateboy (gfx) 0.48 Sun Jan 31 17:53:31 2010 * MouseTypeConstraints.xs - Fix magic handling in type constraints reported by sunnavy (gfx) 0.47 Fri Jan 15 15:07:21 2010 * Makefile.PL - Shipped with M::I::XSUtil 0.21 (gfx) - Fix an issue that gcc 4.0 don't support -Wc++-compat (gfx) * Mouse - Add a caveat on XS callbacks to the pod (gfx) 0.46 Sat Jan 9 17:54:30 2010 * Mouse::Meta::Attribute - Add support for code references for handles patched by Frank Cuny (gfx) * Mouse::Util::TypeConstraints - Fix Str and ScalarRef for typeglobs, lvalues, and etc. (gfx) * oose.pm - Add Moose::Util::TypeConstraints exports to allow easier testing of TypeConsraints from the command line (gfx) 0.4501 Tue Dec 22 16:02:15 2009 * Fix an issue on circular dependencies (RT #52939, thanks to t0m) - (see also http://rt.cpan.org/Public/Bug/Display.html?id=52939 ) 0.45 Sat Dec 19 17:22:46 2009 * Fix filename portability issue (RT #52828, thanks to Peter Edwards) * Fix an issue that definitions of anonymous types could fail (gfx) * Mouse::Meta::Attributes - Add set_value/get_value/has_value/clear_value (gfx) (Note that thsese methods are depend on the accessors) * Test::Mouse - Add with_immutable (gfx) 0.44 Wed Dec 9 21:43:21 2009 * Shipped with Module::Install::XSUtil 0.19 (gfx) * Test::Mouse - Added (gfx) * Mouse::Util::TypeConstraints - Add duck_type (gfx) 0.43 Mon Dec 7 14:21:59 2009 * Improve documents * Mouse::Meta::Module - Remove undocumented has_package_symbol and get_package_symbol (gfx) (They are introduced in 0.41, but seem useless in Mouse) 0.42 Sat Dec 5 16:05:06 2009 * Fix a PAUSE indexing issue (gfx) 0.41 Sat Dec 5 15:00:33 2009 * This is the first stable version of Mouse::XS - Mouse::XS is about 2 times faster than Mouse::PurePerl * SUMMARY - Many stuff are now in XS - Support "use Mouse -traits => ..." subdirective * INCOMPATIBILITY CHANGES (but compatible with Moose) - The type of default value is constrained correctly - The default values is weakend correctly - BUILDALL/DEMOLISHALL are no longer called 0.40_09 Thu Dec 3 13:42:17 2009 * Mouse - Remove @Mouse::EXPORT, which was no longer used (gfx) * Mouse::Role - Remove @Mouse::Role::EXPORT, which was no longer used (gfx) * Mouse::Util - Fix a bug which caused segv on 5.6.2 (gfx) * Mouse::Meta::Module - Add has_package_symbol and get_package_symbol (gfx) 0.40_08 Thu Nov 26 21:36:49 2009 * Mouse::Exporter - Add the "-traits => ..." subdirective (gfx) * Mouse::Meta::Class - Add metaclass incompatibility resolution (gfx) 0.40_07 Tue Nov 17 18:28:57 2009 * Mouse::Util::MetaRole - Implemented, but there are many to be done (gfx) * Mouse::Meta::Method::Accessor * Mouse::Meta::Method::Constructor - Fix a bug that default values are not weaken()ed (gfx) 0.40_06 Mon Nov 16 17:21:10 2009 * Shipped with Module::Install::XSUtil 0.17 (gfx) * Mouse::Object - BUILDALL and DMELISHALL are no longer called by the default ctr/dtr, because generated ctrs/dtrs have never call them anyway (gfx) - new and DESTROY are now in XS (gfx) 0.40_05 Mon Nov 2 11:59:01 2009 * Shipped with Module::Install::XSUtil 0.16 (gfx) 0.40_04 Tue Nov 1 11:58:27 2009 * Implement type constraint generators in XS (gfx) 0.40_03 Fri Oct 30 12:03:58 2009 * Update Module::Install::XSUtil to 0.15 (gfx) 0.40_02 Tue Oct 27 15:04:10 2009 * Add the Mouse::XS documentation (gfx) * Mouse::Meta::Method::Accessor - Apply type constraints to default values as Moose does (gfx) 0.40_01 Mon Oct 26 17:31:23 2009 * Add an optional XS implementation (gfx) 0.40 Mon Oct 19 18:30:32 2009 * Mouse::Meta::TypeConstraint - Fix a subtyping issue (Thanks miyagawa san) (gfx) * Mouse/Mouse::Role - Now export their sugars to the "main" package (gfx) 0.39 Tue Oct 13 16:42:31 2009 * Fix RT #50421 (Thanks Michael G Schwern) * Fix RT #50422 (Thanks Michael G Schwern) 0.38 Tue Oct 13 15:40:39 2009 * No code changes from 0.37_06 * SUMMARY from 0.37 to 0.38 - Add documents about compatiblity and incompatibility to Mouse::Spec - Refactor type constraints and type coercions - Now ArrayRef[Foo | Bar] is parsed correctly - Type coercions are stored in type constraint objects - Add Mouse::Exporter for import/unimport methods - Make roles applicable to instances - Implement inner/augment keywords - Port a lot of Moose's tests - Fix a lot of bugs 0.37_06 Mon Oct 12 16:34:18 2009 * Mouse::Meta::Attribute - Support handles => qr/pattern/ in has() (gfx) * Mouse::Meta::Method::Destructor - Locallize $@ and $? in DESTROY as Moose does (gfx) * Mouse::Meta::Role - Fix role application to instances (gfx) * Tests - Move t/*.t to t/001_moose/ 0.37_05 Fri Oct 9 15:21:43 2009 * Mouse::Exporter - Add build_import_methods() (gfx) * Mouse::Spec - Add notes about Moose::Cookbook (gfx) * Fix some minor bugs (gfx) 0.37_04 Thu Oct 8 20:49:11 2009 * Mouse::Meta::Role::Composite - Fix and improve role composition mechanism (gfx) * Import a number of tests from Moose, and fix various bugs (gfx) * Mouse::Tiny is always generated in Makefile.PL (gfx) 0.37_03 Wed Oct 7 21:10:05 2009 * Mouse::Exporter - Add Mouse::Exporter (gfx) * Mouse::Meta::Method::Constructor - Optimize generated constructors (gfx) * Mouse::Meta::Role - Implement role application to instances (gfx) 0.37_02 Sun Oct 4 17:29:15 2009 * Mouse - Implement the argument/inner keywords * Mouse::Meta::Attribute - Add get_read_method_ref() and get_write_method_ref() (gfx) - Add find_attribute_by_name() (gfx) - Fix clone_and_inherit_options() to deal with 'traits' (gfx) * Mouse::Util - Fix meta() method, which was not tested (gfx) * Tests - Port t/010_basics/*.t from Moose 0.37_01 Thu Oct 1 15:32:58 2009 * Type coercions are stored to type constraints (gfx) * Refactor the type parser to parse 'ArrayRef[Object|Int]' (gfx) * Remove Class::MOP specific subroutines from Mouse::Meta::Module (gfx) (this change might be reverted in the release version) - version, authority, identifier, get_all_metaclasses, store_metaclass_by_name, weaken_metaclass, does_metaclass_exist, remove_metaclass_by_name * Add new public utilities to Mouse::Util (gfx) - class_of, the counterpart for Class::MOP::class_of - get_metaclass_by_name for Class::MOP::get_metaclass_by_name 0.37 Mon Sep 28 10:48:27 2009 * Ensure backward compatibility by author/test-externa.pl (gfx) * Change the algorithm of has_method() for backward compatibility (gfx) * $ENV{MOUSE_VERBOSE}=1 for Moose-compatible warnings (gfx) 0.36 Sun Sep 27 16:53:06 2009 * Fix an issue that breaks backward compatibility (gfx) - MouseX::Attribute does work, although make tests doesn't pass 0.35 Sat Sep 26 12:38:27 2009 * Work around Test::Exception 0.27_0x by including authorized ver. (gfx) 0.34 Fri Sep 25 21:55:48 2009 * Make sure to work on 5.6.2 (gfx) * Remove Class::Method::Modifiers dependency (gfx) * Remove testing modules from inc/ (gfx) * Put t/019-handles.t on ice (gfx) 0.33_01 Thu Sep 24 16:16:57 2009 * Implement traits => [...] in has() (gfx) 0.33 Wed Sep 23 15:06:40 2009 * Fix RT #49902: 0.32 fails tests reported by GRUBER (gfx) * Add some tests 0.32 Tue Sep 22 16:44:57 2009 * Add many tests copied from Moose (gfx) * Fix Mouse::Util::find_meta() and Mouse::Util::does_role() (gfx) * Fix the timing triggers are invoked (gfx) * Implement confliction checks in roles * work around create() and create_anon() in Mouse::Meta::Role 0.31 Tue Sep 22 11:08:12 2009 * Add find_meta() and does_role() to Mouse::Util (gfx) * Fix tests using Class::Method::Modifiers to be skipped correctly (gfx) * Remove Test::Mouse, which was accidentally included (gfx) 0.30 Mon Sep 21 16:43:05 2009 * Implement RT #46930 (accessor/reader/writer in has()) (gfx) * Work around anonymous classes as mortal classes (gfx) * Implement with $role => -exlucdes => [...] (gfx) * Implement get_method() in M::Meta::Class and M::Meta::Role (gfx) * Make get_method_list() compatible with Moose's (gfx) * Make unimport() not to remove non-Mouse functions (blessed and confess) (gfx) * Remove a lot of duplication code (gfx) * Support is => 'bare', and you must pass and 'is' option to has() (gfx) 0.29 Thu Sep 17 11:49:49 2009 * role class has ->meta in method_list, because it does in Moose since 0.9 0.28 Wed Sep 8 20:00:06 2009 * Alter Makefile.PL so in author mode we generate lib/Mouse/Tiny.pm on every run so that 'make dist' actually does what it's meant to (mst) * Only unlink Mouse::Tiny if it exists, otherwise autodie pitches a fit (miyagawa) * Make auto_deref also handles isa not only ArrayRef and HashRef, but also ArrayRef[Foo::Bar] and HashRef[Foo::Bar] 0.27 Thu Jul 2 15:17:37 2009 * Doc updates (Sartak) * Include missing Mouse::Tiny 0.26 Wed Jul 1 13:39:30 2009 * Fix failing tests by requiring a newer Moose in that test (t0m) 0.25 Fri Jun 19 12:05:42 2009 * Fix SIGNATURE (reported by daxim) ... by removing it :) 0.24 Mon Jun 15 14:47:18 2009 * Moose's construct_instance is deprecated, use new_object (tokuhirom) * Improve Mouse::Tiny generation (tokuhirom) * Inlining destructor fixes (tokuhirom) * Add Mouse->init_meta (tokuhirom) * Fix failing tests by requiring a newer Moose in that test (Sartak) * Don't warn in tests about Squirrel deprecations (Sartak) 0.23 Wed May 27 16:52:28 2009 * Take the mro::linearized_isa DEMOLISHALL fix from Moose (originally by doy) * Mouse::class_of to mirror Class::MOP::class_of 0.22 Tue Apr 21 03:26:43 2009 * Regenerate broken signature (Sartak) reported by Michael Gray [rt.cpan.org #45167] * does_role now checks parent classes (tokuhirom) * Fix for $_ not being available type constraint messages (Sartak) 0.21 Sat Apr 11 13:52:11 2009 * clone_instance has been made private, like in Moose (tokuhirom) * Fix method modifiers applying to the wrong class (gfuji) reported by Heikki Lehvaslaiho in [rt.cpan.org #42992] * Fix test failures when user does not have C::Method::Modifiers(::Fast) installed (Joel Bernstein) * use get_all_attributes instead of compute_all_applicable_attributes (tokuhirom) * fixed pod bug (tokuhirom) reported by Ryan52 in [rt.cpan.org #44928] * Parameterized type constraints can now have messages (tokuhirom) * Added documentation about type constraints (Mark Stosberg) 0.20 Thu Apr 9 20:22:33 2009 * Squirrel is now deprecated. Use Any::Moose instead (Sartak) * To improve Moose compat, the third argument to trigger (the attribute metaobject) has been removed (Sartak) * To improve Moose compat, a single undef passed to new is now disallowed (Sartak) * Implemented Mouse::Object->does (wu-lee) * Implemented override and super functions for Mouse::Role. (wu-lee) * Implemented stub augment and inner functions for Mouse::Role, which merely throw an exception as in Moose::Role. (wu-lee) * Stole more tests from Moose (020_roles/*). Not all these pass yet; the rest have been moved to 020_roles/failing for later examination. (wu-lee) * Implemented Mouse::Role->does_role. This does not yet quite seem to pass all the tests it should. (wu-lee) * Fixed bug in Mouse::Meta::Role->apply and ->combine_apply, so that 030_roles/002_role.t tests pass. (wu-lee) * Implemented ->version, ->authority and ->identifier methods in Mouse::Meta::Role and Mouse::Meta::Class (mainly to make more Moose tests pass). (wu-lee) * Implemented emulations of Class::MOP's metaclass accessors (get_metaclass_by_name etc.) in Mouse::Meta::Class. * Mouse attribute property 'isa' now accepts Role names. (wu-lee) * Fixed bug: typecoercion application order was reversed. (wu-lee) * Fixed bug: inlined constructor was invoking BUILD methods in wrong order. (wu-lee) * Fixed bug: immutable constructor now redispatches correctly to Mouse::Object::new when used in derived classes (wu-lee). * Maybe parameterized type constraint (lestrrat) * Performance improvements! (tokuhirom) * Improve Moose compat of class_type (lestrrat) * Many type-constraint fixes (tokuhirom and lestrrat) * Mouse::Meta::Class->has_method and ->get_attribute_list (tokuhirom) * Add get_all_attributes, use it internally instead of compute_all_applicable_attributes (nothingmuch) 0.19 Sun Mar 8 04:38:01 2009 * Parameterized type constraints for ArrayRef and HashRef (lestrrat) * Allow extensible attribute metaclass in traits too(tokuhirom) * Don't use method modifiers in a test since they may not be available (Sartak) 0.18 Fri Mar 6 19:09:33 2009 * Fix the issue preventing Mouse usage on Perl 5.6 - a bug in older Scalar::Util! (tokuhirom) * Allow extensible attribute metaclass (tokuhirom) * Optimization for method modifiers (tokuhirom) * Implement Mouse->import({into_level => 1}) (tokuhirom) * Support for Class->meta->add_attribute($name => %options) (tokuhirom) * Throw a more useful error message when trying to use a parameterized type (Sartak) 0.17 Tue Feb 17 20:10:29 2009 * Load mro directly if Perl is recent enough (Nicholas Clark) * Add dump method from Moose::Object into Mouse::Object (perigrin) * Add role-role composition (tokuhirom) 0.16 Mon Feb 9 20:56:27 2009 * Implement get_all_method_names * Support for anonymous enums: enum [elements] * Moose's make_immutable returns true allowing calling code to skip setting an explicit true value at the end of a source file. (obra) 0.15 Thu Feb 5 11:44:05 2009 * Don't export Mouse's sugar into the package 'main' * Rename Mouse::TypeRegistry to Mouse::Util::TypeConstraints * "type" sugar for when you're not subtyping anything * Keep track of the source package of each type * Moose lets you redefine a type within the same package, so we now do too * Borrow more of Moose's meta API * Mouse::Util::TypeConstraints now uses Exporter so you can select which sugar you want * class_type shouldn't load the class (Moose compat; no easy fix :/) * suppress warnings when we use "around" and "has '+...'" (dann) * use Data::Util to make method modifiers fast if it's available (dann) * Implement "enum" type constraints * Implement "override" and "super" * MouseX::Types is now in its own dist 0.14 Sat Dec 20 16:53:05 2008 * POD fix * Document what changes tokuhirom and Yappo made (see below) 0.13 Tue Dec 16 02:01:40 2008 * Pass in the instance to the default sub in the constructor (reported with failing tests by rjbs) * Tons of new features implemented by tokuhirom++ and Yappo++: - method API in classes and roles! - "requires" and "with" for Mouse::Role - Type coercion - Inject a constructor after make_immutable. Huge speedup! - class_type and role_type - Inject a destructor for more speedup - MouseX::Types (may move into its own dist) - create_anon_class - union type constraints (eg 'Str | Undef') - subtypes and sugar for them 0.12 Thu Dec 4 19:23:10 2008 * Provide Test::Exception function unless it's version 0.27 - RT #41254 * Mouse::Util now provides dies_ok * Make class-like types behave more like Moose; subclasses OK! (rjbs) * Steal more tests from Moose 0.11 Sun Nov 2 11:35:04 2008 * Throw an error if accessor/predicate/clearer/handles code eval fails * Optimizations for generated methods, they should now be on par with Moose 0.10 Tue Oct 28 19:23:07 2008 * Require a recent Moose (which has the bugfix) for t/500_moose_extends_mouse.t * ouse.pm for perl -Mouse one-liners (thanks rjbs) * Doc for init_arg => undef (thanks rjbs) 0.09 Sun Sep 28 22:37:13 2008 * Initial version of Mouse::Tiny, a one-file concatenation of the Mouse classes for easy embedding * Fixes caused by test failures (Carp not being loaded, Moose being required in a test) 0.08 Sun Sep 28 12:46:07 2008 * ALL dependencies have been removed! * Fixes for Class::Method::Modifiers being required for testing 0.07 Sun Sep 28 00:19:07 2008 * All runtime dependencies have been removed! The only change in functionality (hopefully) is that the Sub::Exporter features can no longer be used (we've backed down to regular Exporter). Scalar::Util is required for "weaken" support, and Class::Method::Modifiers is required for method modifier support, but only if you use these features! Having Scalar::Util and MRO::Compat installed will provide only performance increases. * Tests and fixes for extending a Mouse class with Moose (nothingmuch) * Support for adding method modifiers to a role, and composing them into classes (we'll get true methods some day) * Method modifiers now go through the metaclass instead of invoking Class::Method::Modifiers directly * Remove the deprecated before/after/around triggers * Roles keywords 'requires' and 'excludes' now throw errors instead of silently doing nothing (they aren't implemented yet) 0.06 Thu Jul 23 02:10:07 2008 * Deprecating before/after/around triggers! Switch back to coderef + whatever you used to do. Moose is have it implemented it as an extension trait. * Mouse - updated trigger doc (thanks perigrin) - which will not see CPAN :( sorry perigrin! * Mouse::Meta::Class - add a make_immutable method which does nothing(!), for even more Moose compat (nothingmuch's idea) 0.05 Thu Jul 17 01:53:20 2008 * Mouse::Role Mouse::Meta::Role Mouse Squirrel::Role - Begin adding roles! Attributes are mostly there. Still experimental. * Mouse::Meta::Class Mouse::Object - Add clone_object and clone_instance (nothingmuch) * Mouse::Object - Add BUILDARGS (nothingmuch) * Mouse::Meta::Attribute Mouse::Object - Add "before" and "around" triggers. Moose doesn't even have them yet! :) * Everywhere - Improvements to the MOP (e.g. Class->add_method) * (build) - Excise dependency on Test::Warn, we only used it in one simple test 0.04 Tue Jun 17 04:56:36 2008 * Mouse Mouse::Meta::Attribute - Add support for has '+name' - Add lazy_build (nothingmuch) 0.03 Thu Jun 12 21:54:07 2008 * Mouse - Add before/after/around, courtesy of Class::Method::Modifiers * Mouse::Object - Add support for ->new({...}) - Use compute_all_applicable_attributes in the constructor to get the attributes of superclasses - Add better support for undef init_arg * Mouse::Meta::Class - More methods: compute_all_applicable_attributes, has_attribute 0.02 Wed Jun 11 01:56:44 2008 * Squirrel - Add Squirrel which acts as Moose if it's already loaded, otherwise Mouse (thanks nothingmuch) * Mouse::Meta::Object - Fix the order in which BUILD methods are called (thanks Robert Boone) 0.01 Tue Jun 10 02:13:21 2008 * Initial release. LICENSE000644000765000024 4375712245117717 13006 0ustar00gfxstaff000000000000Mouse-2.1.0This software is copyright (c) 2013 by Shawn M Moore . 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 Shawn M Moore . 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 Shawn M Moore . 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 MANIFEST.SKIP000644000765000024 24512245117717 13620 0ustar00gfxstaff000000000000Mouse-2.1.0# Moose specific tests xt/compat xt/external failing ^TODO$ # author's tools author/ lib/Mouse/Tiny\.pm$ ppport\.h$ MYMETA\.(?:yml|json)$ Moose-t/ xshelper\.h$ META.json000644000765000024 1505112245117717 13404 0ustar00gfxstaff000000000000Mouse-2.1.0{ "abstract" : "Moose minus the antlers", "author" : [ "Shawn M Moore " ], "dynamic_config" : 0, "generated_by" : "Minilla/v0.10.0", "license" : [ "perl_5" ], "meta-spec" : { "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec", "version" : "2" }, "name" : "Mouse", "no_index" : { "directory" : [ "t", "xt", "tool", "author", "example", "benchmarks", "builder" ] }, "prereqs" : { "configure" : { "requires" : { "CPAN::Meta" : "0", "CPAN::Meta::Prereqs" : "0", "Devel::PPPort" : "3.19", "ExtUtils::ParseXS" : "3.22", "Module::Build" : "0.38", "Module::Build::XSUtil" : "0" } }, "develop" : { "requires" : { "Test::CPAN::Meta" : "0", "Test::DependentModules" : "0", "Test::MinimumVersion" : "0.10108", "Test::Pod" : "1.41", "Test::Pod::Coverage" : "0", "Test::Spellunker" : "v0.2.7" }, "suggests" : { "Declare::Constraints::Simple" : "0", "HTTP::Headers" : "0", "IO::String" : "0", "Locale::US" : "0", "Params::Coerce" : "0", "Regexp::Common" : "0", "Test::Deep" : "0", "URI" : "0" } }, "runtime" : { "requires" : { "Scalar::Util" : "1.14", "XSLoader" : "0.02", "perl" : "v5.8.1" } }, "test" : { "requires" : { "Test::Exception" : "0", "Test::Exception::LessClever" : "0", "Test::Fatal" : "0", "Test::LeakTrace" : "0", "Test::More" : "0.88", "Test::Output" : "0", "Test::Requires" : "0", "Try::Tiny" : "0" } } }, "provides" : { "Mouse" : { "file" : "lib/Mouse.pm", "version" : "v2.1.0" }, "Mouse::Exporter" : { "file" : "lib/Mouse/Exporter.pm" }, "Mouse::Meta::Attribute" : { "file" : "lib/Mouse/Meta/Attribute.pm" }, "Mouse::Meta::Class" : { "file" : "lib/Mouse/Meta/Class.pm" }, "Mouse::Meta::Method" : { "file" : "lib/Mouse/Meta/Method.pm" }, "Mouse::Meta::Method::Accessor" : { "file" : "lib/Mouse/Meta/Method/Accessor.pm" }, "Mouse::Meta::Method::Constructor" : { "file" : "lib/Mouse/Meta/Method/Constructor.pm" }, "Mouse::Meta::Method::Delegation" : { "file" : "lib/Mouse/Meta/Method/Delegation.pm" }, "Mouse::Meta::Method::Destructor" : { "file" : "lib/Mouse/Meta/Method/Destructor.pm" }, "Mouse::Meta::Module" : { "file" : "lib/Mouse/Meta/Module.pm" }, "Mouse::Meta::Role" : { "file" : "lib/Mouse/Meta/Role.pm" }, "Mouse::Meta::Role::Application" : { "file" : "lib/Mouse/Meta/Role/Application.pm" }, "Mouse::Meta::Role::Application::RoleSummation" : { "file" : "lib/Mouse/Tiny.pm" }, "Mouse::Meta::Role::Composite" : { "file" : "lib/Mouse/Meta/Role/Composite.pm" }, "Mouse::Meta::Role::Method" : { "file" : "lib/Mouse/Meta/Role/Method.pm" }, "Mouse::Meta::TypeConstraint" : { "file" : "lib/Mouse/Meta/TypeConstraint.pm" }, "Mouse::Object" : { "file" : "lib/Mouse/Object.pm" }, "Mouse::PurePerl" : { "file" : "lib/Mouse/PurePerl.pm" }, "Mouse::Role" : { "file" : "lib/Mouse/Role.pm", "version" : "v2.1.0" }, "Mouse::Spec" : { "file" : "lib/Mouse/Spec.pm", "version" : "v2.1.0" }, "Mouse::Tiny" : { "file" : "lib/Mouse/Tiny.pm", "version" : "v2.1.0" }, "Mouse::TypeRegistry" : { "file" : "lib/Mouse/TypeRegistry.pm" }, "Mouse::Util" : { "file" : "lib/Mouse/Util.pm", "version" : "v2.1.0" }, "Mouse::Util::MetaRole" : { "file" : "lib/Mouse/Util/MetaRole.pm" }, "Mouse::Util::TypeConstraints" : { "file" : "lib/Mouse/Util/TypeConstraints.pm" }, "Squirrel" : { "file" : "lib/Squirrel.pm" }, "Squirrel::Role" : { "file" : "lib/Squirrel/Role.pm" }, "Test::Mouse" : { "file" : "lib/Test/Mouse.pm" }, "ouse" : { "file" : "lib/ouse.pm" } }, "release_status" : "stable", "resources" : { "bugtracker" : { "web" : "https://github.com/gfx/p5-Mouse/issues" }, "homepage" : "https://github.com/gfx/p5-Mouse", "repository" : { "url" : "git://github.com/gfx/p5-Mouse.git", "web" : "https://github.com/gfx/p5-Mouse" } }, "version" : "2.1.0", "x_contributors" : [ "Ricardo SIGNES ", "大沢 和宏 ", "Dann ", "Jesse Vincent ", "Chris Prather ", "Tokuhiro Matsuno ", "Daisuke Maki ", "Nick Woolley ", "Daisuke Maki (lestrrat) ", "NAKAGAWA Masaki ", "wu-lee ", "Yuval Kogman ", "Joel Bernstein ", "markstos ", "Chris Prather ", "Tomas Doran (t0m) ", "Matt S Trout ", "sunnavy ", "Shawn M Moore ", "Ævar Arnfjörð Bjarmason ", "Vincent Pit ", "Brett ", "Shawn M Moore ", "Ingy dot Net ", "Todd Rinaldo ", "Fuji, Goro ", "Piotr Roszatycki ", "Stanislaw Pusep ", "Michael G. Schwern ", "Fuji, Goro ", "David Steinbrunner ", "Masahiro Honma ", "Fuji, Goro ", "tokuhirom ", "Fuji, Goro (gfx) " ] } README.md000644000765000024 2324112245117717 13242 0ustar00gfxstaff000000000000Mouse-2.1.0[![Build Status](https://travis-ci.org/gfx/p5-Mouse.png?branch=master)](https://travis-ci.org/gfx/p5-Mouse) # NAME Mouse - Moose minus the antlers # VERSION This document describes Mouse version 2.1.0 # SYNOPSIS package Point; use Mouse; # automatically turns on strict and warnings has 'x' => (is => 'rw', isa => 'Int'); has 'y' => (is => 'rw', isa => 'Int'); sub clear { my($self) = @_; $self->x(0); $self->y(0); } __PACKAGE__->meta->make_immutable(); package Point3D; use Mouse; extends 'Point'; has 'z' => (is => 'rw', isa => 'Int'); after 'clear' => sub { my($self) = @_; $self->z(0); }; __PACKAGE__->meta->make_immutable(); # DESCRIPTION [Moose](http://search.cpan.org/perldoc?Moose) is a postmodern object system for Perl5. Moose is wonderful. Unfortunately, Moose has a compile-time penalty. Though significant progress has been made over the years, the compile time penalty is a non-starter for some very specific applications. If you are writing a command-line application or CGI script where startup time is essential, you may not be able to use Moose (we recommend that you instead use persistent Perl executing environments like `FastCGI` for the latter, if possible). Mouse is a Moose compatible object system, which aims to alleviate this penalty by providing a subset of Moose's functionality. We're also going as light on dependencies as possible. Mouse currently has __no dependencies__ except for building/testing modules. Mouse also works without XS, although it has an XS backend to make it much faster. ## Moose Compatibility Compatibility with Moose has been the utmost concern. The sugary interface is highly compatible with Moose. Even the error messages are taken from Moose. The Mouse code just runs its test suite 4x faster. The idea is that, if you need the extra power, you should be able to run `s/Mouse/Moose/g` on your codebase and have nothing break. To that end, we have written [Any::Moose](http://search.cpan.org/perldoc?Any::Moose) which will act as Mouse unless Moose is loaded, in which case it will act as Moose. Since Mouse is a little sloppier than Moose, if you run into weird errors, it would be worth running: ANY_MOOSE=Moose perl your-script.pl to see if the bug is caused by Mouse. Moose's diagnostics and validation are also better. See also [Mouse::Spec](http://search.cpan.org/perldoc?Mouse::Spec) for compatibility and incompatibility with Moose. ## Mouse Extentions Please don't copy MooseX code to MouseX. If you need extensions, you really should upgrade to Moose. We don't need two parallel sets of extensions! If you really must write a Mouse extension, please contact the Moose mailing list or \#moose on IRC beforehand. # KEYWORDS ## `$object->meta -> Mouse::Meta::Class` Returns this class' metaclass instance. ## `extends superclasses` Sets this class' superclasses. ## `before (method|methods|regexp) => CodeRef` Installs a "before" method modifier. See ["before" in Moose](http://search.cpan.org/perldoc?Moose#before). ## `after (method|methods|regexp) => CodeRef` Installs an "after" method modifier. See ["after" in Moose](http://search.cpan.org/perldoc?Moose#after). ## `around (method|methods|regexp) => CodeRef` Installs an "around" method modifier. See ["around" in Moose](http://search.cpan.org/perldoc?Moose#around). ## `has (name|names) => parameters` Adds an attribute (or if passed an arrayref of names, multiple attributes) to this class. Options: - `is => ro|rw|bare` The _is_ option accepts either _rw_ (for read/write), _ro_ (for read only) or _bare_ (for nothing). These will create either a read/write accessor or a read-only accessor respectively, using the same name as the `$name` of the attribute. If you need more control over how your accessors are named, you can use the `reader`, `writer` and `accessor` options, however if you use those, you won't need the _is_ option. - `isa => TypeName | ClassName` Provides type checking in the constructor and accessor. The following types are supported. Any unknown type is taken to be a class check (e.g. `isa => 'DateTime'` would accept only [DateTime](http://search.cpan.org/perldoc?DateTime) objects). Any Item Bool Undef Defined Value Num Int Str ClassName Ref ScalarRef ArrayRef HashRef CodeRef RegexpRef GlobRef FileHandle Object For more documentation on type constraints, see [Mouse::Util::TypeConstraints](http://search.cpan.org/perldoc?Mouse::Util::TypeConstraints). - `does => RoleName` This will accept the name of a role which the value stored in this attribute is expected to have consumed. - `coerce => Bool` This will attempt to use coercion with the supplied type constraint to change the value passed into any accessors or constructors. You __must__ have supplied a type constraint in order for this to work. See [Moose::Cookbook::Basics::Recipe5](http://search.cpan.org/perldoc?Moose::Cookbook::Basics::Recipe5) for an example. - `required => Bool` Whether this attribute is required to have a value. If the attribute is lazy or has a builder, then providing a value for the attribute in the constructor is optional. - `init_arg => Str | Undef` Allows you to use a different key name in the constructor. If undef, the attribute can't be passed to the constructor. - `default => Value | CodeRef` Sets the default value of the attribute. If the default is a coderef, it will be invoked to get the default value. Due to quirks of Perl, any bare reference is forbidden, you must wrap the reference in a coderef. Otherwise, all instances will share the same reference. - `lazy => Bool` If specified, the default is calculated on demand instead of in the constructor. - `predicate => Str` Lets you specify a method name for installing a predicate method, which checks that the attribute has a value. It will not invoke a lazy default or builder method. - `clearer => Str` Lets you specify a method name for installing a clearer method, which clears the attribute's value from the instance. On the next read, lazy or builder will be invoked. - `handles => HashRef|ArrayRef|Regexp` Lets you specify methods to delegate to the attribute. ArrayRef forwards the given method names to method calls on the attribute. HashRef maps local method names to remote method names called on the attribute. Other forms of ["handles"](#handles), such as RoleName and CodeRef, are not yet supported. - `weak_ref => Bool` Lets you automatically weaken any reference stored in the attribute. Use of this feature requires [Scalar::Util](http://search.cpan.org/perldoc?Scalar::Util)! - `trigger => CodeRef` Any time the attribute's value is set (either through the accessor or the constructor), the trigger is called on it. The trigger receives as arguments the instance, and the new value. - `builder => Str` Defines a method name to be called to provide the default value of the attribute. `builder => 'build_foo'` is mostly equivalent to `default => sub { $_[0]->build_foo }`. - `auto_deref => Bool` Allows you to automatically dereference ArrayRef and HashRef attributes in list context. In scalar context, the reference is returned (NOT the list length or bucket status). You must specify an appropriate type constraint to use auto\_deref. - `lazy_build => Bool` Automatically define the following options: has $attr => ( # ... lazy => 1 builder => "_build_$attr", clearer => "clear_$attr", predicate => "has_$attr", ); ## `confess(message) -> BOOM` ["confess" in Carp](http://search.cpan.org/perldoc?Carp#confess) for your convenience. ## `blessed(value) -> ClassName | undef` ["blessed" in Scalar::Util](http://search.cpan.org/perldoc?Scalar::Util#blessed) for your convenience. # MISC ## import Importing Mouse will default your class' superclass list to [Mouse::Object](http://search.cpan.org/perldoc?Mouse::Object). You may use ["extends"](#extends) to replace the superclass list. ## unimport Please unimport Mouse (`no Mouse`) so that if someone calls one of the keywords (such as ["extends"](#extends)) it will break loudly instead breaking subtly. # SOURCE CODE ACCESS We have a public git repository [https://github.com/gfx/p5-Mouse](https://github.com/gfx/p5-Mouse):. git clone git://github.com/gfx/p5-Mouse.git # DEPENDENCIES Perl 5.6.2 or later. # SEE ALSO [Mouse::Role](http://search.cpan.org/perldoc?Mouse::Role) [Mouse::Spec](http://search.cpan.org/perldoc?Mouse::Spec) [Moose](http://search.cpan.org/perldoc?Moose) [Moose::Manual](http://search.cpan.org/perldoc?Moose::Manual) [Moose::Cookbook](http://search.cpan.org/perldoc?Moose::Cookbook) [Class::MOP](http://search.cpan.org/perldoc?Class::MOP) [Moo](http://search.cpan.org/perldoc?Moo) # AUTHORS Shawn M Moore Yuval Kogman tokuhirom Yappo wu-lee Goro Fuji (gfx) with plenty of code borrowed from [Class::MOP](http://search.cpan.org/perldoc?Class::MOP) and [Moose](http://search.cpan.org/perldoc?Moose) # BUGS All complex software has bugs lurking in it, and this module is no exception. Please report any bugs to `bug-mouse at rt.cpan.org`, or through the web interface at [http://rt.cpan.org/Public/Dist/Display.html?Name=Mouse](http://rt.cpan.org/Public/Dist/Display.html?Name=Mouse) # COPYRIGHT AND LICENSE Copyright (c) 2008-2010 Infinity Interactive, Inc. http://www.iinteractive.com/ This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. accessors.pl000644000765000024 442312245117717 16403 0ustar00gfxstaff000000000000Mouse-2.1.0/benchmarks#!perl use strict; use Benchmark qw(:all); use Config; printf "Perl/%vd in $Config{archname}\n\n", $^V; use warnings; no warnings 'once'; my $cxsa_is_loaded = eval q{ package CXSA; use Class::XSAccessor constructor => 'new', accessors => { simple => 'simple', }, ; 1; }; { package Foo; sub new { bless {}, shift } } { package MouseOne; use Mouse; has simple => ( is => 'rw', ); has with_lazy => ( is => 'rw', lazy => 1, default => 42, ); __PACKAGE__->meta->make_immutable; } { package MooseOne; use Moose; has simple => ( is => 'rw', ); has with_lazy => ( is => 'rw', lazy => 1, default => 42, ); __PACKAGE__->meta->make_immutable; } use B qw(svref_2object); print "Moose/$Moose::VERSION (Class::MOP/$Class::MOP::VERSION)\n"; print "Mouse/$Mouse::VERSION\n"; print "Class::XSAccessor/$Class::XSAccessor::VERSION\n" if $cxsa_is_loaded; my $mi = MouseOne->new(); my $mx = MooseOne->new(); my $cx; $cx = CXSA->new if $cxsa_is_loaded; print "\nGETTING for simple attributes\n"; cmpthese -1 => { 'Mouse' => sub{ my $x; $x = $mi->simple(); $x = $mi->simple(); }, 'Moose' => sub{ my $x; $x = $mx->simple(); $x = $mx->simple(); }, $cxsa_is_loaded ? ( 'C::XSAccessor' => sub{ my $x; $x = $cx->simple(); $x = $cx->simple(); }, ) : (), }; print "\nSETTING for simple attributes\n"; cmpthese -1 => { 'Mouse' => sub{ $mi->simple(10); $mi->simple(10); }, 'Moose' => sub{ $mx->simple(10); $mx->simple(10); }, $cxsa_is_loaded ? ( 'C::XSAccessor' => sub{ $cx->simple(10); $cx->simple(10); }, ) : (), }; print "\nGETTING for lazy attributes (except for C::XSAccessor)\n"; cmpthese -1 => { 'Mouse' => sub{ my $x; $x = $mi->with_lazy(); $x = $mi->with_lazy(); }, 'Moose' => sub{ my $x; $x = $mx->with_lazy(); $x = $mx->with_lazy(); }, $cxsa_is_loaded ? ( 'C::XSAccessor' => sub{ my $x; $x = $cx->simple(); $x = $cx->simple(); }, ) : (), }; basic.pl000644000765000024 231212245117717 15472 0ustar00gfxstaff000000000000Mouse-2.1.0/benchmarks#!perl use strict; use warnings; use Benchmark qw/cmpthese/; for my $klass (qw/Moose Mouse/) { eval qq{ package ${klass}One; use $klass; has n => ( is => 'rw', isa => 'Int', ); has m => ( is => 'rw', isa => 'Int', default => 42, ); no $klass; __PACKAGE__->meta->make_immutable; }; die $@ if $@; } print "Class::MOP: $Class::MOP::VERSION\n"; print "Moose: $Moose::VERSION\n"; print "Mouse: $Mouse::VERSION\n"; print "---- new\n"; cmpthese( -1 => { map { my $x = $_; $_ => sub { $x->new(n => 3) } } map { "${_}One" } qw/Moose Mouse/ } ); print "---- new,set\n"; cmpthese( -1 => { map { my $y = $_; $_ => sub { $y->new(n => 3)->n(5) } } map { "${_}One" } qw/Moose Mouse/ } ); print "---- set\n"; my %c = map { $_ => "${_}One"->new(n => 3) } qw/Moose Mouse/; cmpthese( -1 => { map { my $y = $_; $_ => sub { $c{$y}->n(5) } } qw/Moose Mouse/ } ); print "---- get\n"; cmpthese( -1 => { map { my $y = $_; $_ => sub { $c{$y}->n() } } qw/Moose Mouse/ } ); class_type.pl000644000765000024 233512245117717 16564 0ustar00gfxstaff000000000000Mouse-2.1.0/benchmarks#!perl use strict; use warnings; use Benchmark qw/cmpthese/; { package Foo; sub new{ bless {}, shift } } eval q{ package C::XSAOne; use Class::XSAccessor constructor => 'new', accessors => { n => 'n' }, ; 1; }; for my $klass (qw/Moose Mouse/) { eval qq{ package ${klass}One; use $klass; has n => ( is => 'rw', isa => 'Foo', ); no $klass; __PACKAGE__->meta->make_immutable; }; die $@ if $@; } print "Class::MOP: $Class::MOP::VERSION\n"; print "Moose: $Moose::VERSION\n"; print "Mouse: $Mouse::VERSION\n"; print "---- new\n"; my $foo = Foo->new(); my @classes = qw(Moose Mouse); if(C::XSAOne->can('new')){ push @classes, 'C::XSA'; } cmpthese( -1 => { map { my $x = $_; $_ => sub { $x->new(n => $foo) } } map { "${_}One" } @classes } ); print "---- new,set\n"; cmpthese( -1 => { map { my $y = $_; $_ => sub { $y->new(n => $foo)->n($foo) } } map { "${_}One" } @classes } ); print "---- set\n"; my %c = map { $_ => "${_}One"->new(n => $foo) } @classes; cmpthese( -1 => { map { my $y = $_; $_ => sub { $c{$y}->n($foo) } } @classes } ); coercion.pl000644000765000024 230712245117717 16216 0ustar00gfxstaff000000000000Mouse-2.1.0/benchmarks#!perl use strict; use warnings; use Benchmark qw/cmpthese/; for my $klass (qw/Moose Mouse/) { eval qq{ package ${klass}One; use $klass; use ${klass}::Util::TypeConstraints; subtype 'NaturalNumber', as 'Int', where { \$_ > 0 }; coerce 'NaturalNumber', from 'Str', via { 42 }, ; has n => ( is => 'rw', isa => 'NaturalNumber', coerce => 1, ); no $klass; __PACKAGE__->meta->make_immutable; }; die $@ if $@; } print "Class::MOP: $Class::MOP::VERSION\n"; print "Moose: $Moose::VERSION\n"; print "Mouse: $Mouse::VERSION\n"; print "---- new\n"; cmpthese( -1 => { map { my $x = $_; $_ => sub { $x->new(n => 'foo') } } map { "${_}One" } qw/Moose Mouse/ } ); print "---- new,set\n"; cmpthese( -1 => { map { my $y = $_; $_ => sub { $y->new(n => 'foo')->n('bar') } } map { "${_}One" } qw/Moose Mouse/ } ); print "---- set\n"; my %c = map { $_ => "${_}One"->new(n => 'foo') } qw/Moose Mouse/; cmpthese( -1 => { map { my $y = $_; $_ => sub { $c{$y}->n('bar') } } qw/Moose Mouse/ } ); constructor.pl000644000765000024 241412245117717 17001 0ustar00gfxstaff000000000000Mouse-2.1.0/benchmarks#!perl ### MODULES { package PlainMoose; use Moose; has foo => (is => 'rw'); has bar => (is => 'rw'); __PACKAGE__->meta->make_immutable(); } { package PlainMooseSC; use Moose; use MooseX::StrictConstructor; has foo => (is => 'rw'); has bar => (is => 'rw'); __PACKAGE__->meta->make_immutable(); } { package PlainMouse; use Mouse; has foo => (is => 'rw'); has bar => (is => 'rw'); __PACKAGE__->meta->make_immutable(); } { package PlainMouseSC; use Mouse; has foo => (is => 'rw'); has bar => (is => 'rw'); __PACKAGE__->meta->make_immutable(strict_constructor => 1); } { package CAF; use warnings; use strict; use base 'Class::Accessor::Fast'; __PACKAGE__->mk_accessors(qw(foo bar)); } use Benchmark qw(cmpthese); print "\nCREATION AND DESTRUCTION\n"; cmpthese(-1, { Moose => sub { my $x = PlainMoose->new(foo => 23, bar => 42) }, Mouse => sub { my $x = PlainMouse->new(foo => 23, bar => 42) }, MooseSC => sub { my $x = PlainMooseSC->new(foo => 23, bar => 42) }, MouseSC => sub { my $x = PlainMouseSC->new(foo => 23, bar => 42) }, ClassAccessorFast => sub { my $x = CAF->new({foo => 23, bar => 42}) }, }, 'noc'); load_class.pl000644000765000024 55012245117717 16477 0ustar00gfxstaff000000000000Mouse-2.1.0/benchmarks#!perl use strict; use warnings; use Benchmark qw/cmpthese/; use Class::MOP; use Mouse(); print "Class::MOP $Class::MOP::VERSION\n"; print "Mouse $Mouse::VERSION\n"; cmpthese -1 => { 'Class::MOP' => sub{ Class::MOP::load_class('Class::MOP::Class'); }, 'Mouse' => sub{ Mouse::Util::load_class('Class::MOP::Class'); }, }; modifiers.pl000644000765000024 413112245117717 16373 0ustar00gfxstaff000000000000Mouse-2.1.0/benchmarks#!perl -w use strict; use Benchmark qw(:all); use Config; use Moose (); use Mouse (); use Class::Method::Modifiers (); printf "Perl %vd on $Config{archname}\n", $^V; my @mods = qw(Moose Mouse Class::Method::Modifiers); foreach my $class(@mods){ print "$class ", $class->VERSION, "\n"; } print "\n"; { package Base; sub f{ 42 } sub g{ 42 } sub h{ 42 } } my $i = 0; sub around{ my $next = shift; $i++; goto &{$next}; } { package CMM; use parent -norequire => qw(Base); use Class::Method::Modifiers; before f => sub{ $i++ }; around g => \&main::around; after h => sub{ $i++ }; } { package MooseClass; use parent -norequire => qw(Base); use Moose; before f => sub{ $i++ }; around g => \&main::around; after h => sub{ $i++ }; } { package MouseClass; use parent -norequire => qw(Base); use Mouse; before f => sub{ $i++ }; around g => \&main::around; after h => sub{ $i++ }; } print "Calling methods with before modifiers:\n"; cmpthese -1 => { CMM => sub{ my $old = $i; CMM->f(); $i == ($old+1) or die $i; }, Moose => sub{ my $old = $i; MooseClass->f(); $i == ($old+1) or die $i; }, Mouse => sub{ my $old = $i; MouseClass->f(); $i == ($old+1) or die $i; }, }; print "\n", "Calling methods with around modifiers:\n"; cmpthese -1 => { CMM => sub{ my $old = $i; CMM->g(); $i == ($old+1) or die $i; }, Moose => sub{ my $old = $i; MooseClass->g(); $i == ($old+1) or die $i; }, Mouse => sub{ my $old = $i; MouseClass->g(); $i == ($old+1) or die $i; }, }; print "\n", "Calling methods with after modifiers:\n"; cmpthese -1 => { CMM => sub{ my $old = $i; CMM->h(); $i == ($old+1) or die $i; }, Moose => sub{ my $old = $i; MooseClass->h(); $i == ($old+1) or die $i; }, Mouse => sub{ my $old = $i; MouseClass->h(); $i == ($old+1) or die $i; }, }; new_object.pl000644000765000024 117512245117717 16536 0ustar00gfxstaff000000000000Mouse-2.1.0/benchmarks#!perl -w use strict; use Benchmark qw(:all); { package MyMoose; use Moose; has [qw(foo bar baz)] => ( is => 'rw', isa => 'Str', default => 'qux', ); __PACKAGE__->meta->make_immutable(); } { package MyMouse; use Mouse; has [qw(foo bar baz)] => ( is => 'rw', isa => 'Str', default => 'qux', ); __PACKAGE__->meta->make_immutable(); } print "Class->meta->new_object x 10\n"; cmpthese -1, { Moose => sub { MyMoose->meta->new_object() for 10; }, Mouse => sub { MyMouse->meta->new_object() for 10; }, }; subtype.pl000644000765000024 247412245117717 16115 0ustar00gfxstaff000000000000Mouse-2.1.0/benchmarks#!perl use strict; use warnings; use Benchmark qw/cmpthese/; for my $klass (qw/Moose Mouse/) { eval qq{ package ${klass}One; use $klass; use ${klass}::Util::TypeConstraints; subtype 'NaturalNumber', as 'Int', where { \$_ > 0 }; has n => ( is => 'rw', isa => 'NaturalNumber', ); no $klass; __PACKAGE__->meta->make_immutable; }; die $@ if $@; } #use Data::Dumper; #$Data::Dumper::Deparse = 1; #$Data::Dumper::Indent = 1; #print Mouse::Util::TypeConstraints::find_type_constraint('NaturalNumber')->dump(3); #print Moose::Util::TypeConstraints::find_type_constraint('NaturalNumber')->dump(3); print "Class::MOP: $Class::MOP::VERSION\n"; print "Moose: $Moose::VERSION\n"; print "Mouse: $Mouse::VERSION\n"; print "---- new\n"; cmpthese( -1 => { map { my $x = $_; $_ => sub { $x->new(n => 3) } } map { "${_}One" } qw/Moose Mouse/ } ); print "---- new,set\n"; cmpthese( -1 => { map { my $y = $_; $_ => sub { $y->new(n => 3)->n(5) } } map { "${_}One" } qw/Moose Mouse/ } ); print "---- set\n"; my %c = map { $_ => "${_}One"->new(n => 3) } qw/Moose Mouse/; cmpthese( -1 => { map { my $y = $_; $_ => sub { $c{$y}->n(5) } } qw/Moose Mouse/ } ); type_constraints.pl000644000765000024 774412245117717 20037 0ustar00gfxstaff000000000000Mouse-2.1.0/benchmarks#!perl use strict; use Benchmark qw(:all); use Config; printf "Perl/%vd in $Config{archname}\n\n", $^V; use warnings; no warnings 'once'; my $cxsa_is_loaded = eval q{ package CXSA; use Class::XSAccessor constructor => 'new', accessors => { simple => 'simple', }, ; 1; }; { package Foo; sub new { bless {}, shift } } { package MouseOne; use Mouse; use Mouse::Util::TypeConstraints; has simple => ( is => 'rw', ); has with_lazy => ( is => 'rw', lazy => 1, default => 42, ); has with_tc => ( is => 'rw', isa => 'Int', ); has with_tc_class_type => ( is => 'rw', isa => 'Foo', ); has with_tc_array_of_int => ( is => 'rw', isa => 'ArrayRef[Int]', ); has with_tc_duck_type => ( is => 'rw', isa => duck_type([qw(simple)]), ); __PACKAGE__->meta->make_immutable; } { package MooseOne; use Moose; use Moose::Util::TypeConstraints; has simple => ( is => 'rw', ); has with_lazy => ( is => 'rw', lazy => 1, default => 42, ); has with_tc => ( is => 'rw', isa => 'Int', ); has with_tc_class_type => ( is => 'rw', isa => 'Foo', ); has with_tc_array_of_int => ( is => 'rw', isa => 'ArrayRef[Int]', ); has with_tc_duck_type => ( is => 'rw', isa => duck_type([qw(simple)]), ); __PACKAGE__->meta->make_immutable; } use B qw(svref_2object); print "Moose/$Moose::VERSION (Class::MOP/$Class::MOP::VERSION)\n"; print "Mouse/$Mouse::VERSION\n"; print "Class::XSAccessor/$Class::XSAccessor::VERSION\n" if $cxsa_is_loaded; my $mi = MouseOne->new(); my $mx = MooseOne->new(); my $cx; $cx = CXSA->new if $cxsa_is_loaded; print "\nSETTING for simple attributes\n"; cmpthese -1 => { 'Mouse' => sub{ $mi->simple(10); $mi->simple(10); }, 'Moose' => sub{ $mx->simple(10); $mx->simple(10); }, $cxsa_is_loaded ? ( 'C::XSAccessor' => sub{ $cx->simple(10); $cx->simple(10); }, ) : (), }; print "\nSETTING for attributes with type constraints 'Int' (except for C::XSAccessor)\n"; cmpthese -1 => { 'Mouse' => sub{ $mi->with_tc(10); $mi->with_tc(10); }, 'Moose' => sub{ $mx->with_tc(10); $mx->with_tc(10); }, $cxsa_is_loaded ? ( 'C::XSAccessor' => sub{ $cx->simple(10); $cx->simple(10); }, ) : (), }; print "\nSETTING for attributes with type constraints 'Foo' (except for C::XSAccessor)\n"; my $foo = Foo->new; cmpthese -1 => { 'Mouse' => sub{ $mi->with_tc_class_type($foo); $mi->with_tc_class_type($foo); }, 'Moose' => sub{ $mx->with_tc_class_type($foo); $mx->with_tc_class_type($foo); }, $cxsa_is_loaded ? ( 'C::XSAccessor' => sub{ $cx->simple($foo); $cx->simple($foo); }, ) : (), }; print "\nSETTING for attributes with type constraints 'ArrayRef[Int]' (except for C::XSAccessor)\n"; $foo = [10, 20]; cmpthese -1 => { 'Mouse' => sub{ $mi->with_tc_array_of_int($foo); $mi->with_tc_array_of_int($foo); }, 'Moose' => sub{ $mx->with_tc_array_of_int($foo); $mx->with_tc_array_of_int($foo); }, $cxsa_is_loaded ? ( 'C::XSAccessor' => sub{ $cx->simple($foo); $cx->simple($foo); }, ) : (), }; print "\nSETTING for attributes with type constraints duck_type() (except for C::XSAccessor)\n"; $foo = MouseOne->new(); cmpthese -1 => { 'Mouse' => sub{ $mi->with_tc_duck_type($foo); $mi->with_tc_duck_type($foo); }, 'Moose' => sub{ $mx->with_tc_duck_type($foo); $mx->with_tc_duck_type($foo); }, $cxsa_is_loaded ? ( 'C::XSAccessor' => sub{ $cx->simple($foo); $cx->simple($foo); }, ) : (), }; vs_caf.pl000644000765000024 244412245117717 15660 0ustar00gfxstaff000000000000Mouse-2.1.0/benchmarks#!perl ### MODULES { package PlainMoose; use Moose; has foo => (is => 'rw'); __PACKAGE__->meta->make_immutable(); } { package PlainMouse; use Mouse; has foo => (is => 'rw'); __PACKAGE__->meta->make_immutable(); } { package ClassAccessorFast; use warnings; use strict; use base 'Class::Accessor::Fast'; __PACKAGE__->mk_accessors(qw(foo)); } use Benchmark qw(cmpthese); my $moose = PlainMoose->new; my $mouse = PlainMouse->new; my $caf = ClassAccessorFast->new; print "\nSETTING\n"; cmpthese(-1, { Moose => sub { $moose->foo(23) }, Mouse => sub { $mouse->foo(23) }, ClassAccessorFast => sub { $caf->foo(23) }, }, 'noc'); print "\nGETTING\n"; cmpthese(-1, { Moose => sub { $moose->foo }, Mouse => sub { $mouse->foo }, ClassAccessorFast => sub { $caf->foo }, }, 'noc'); print "\nCREATION AND DESTRUCTION\n"; cmpthese(-1, { Moose => sub { my $x = PlainMoose->new(foo => 23) }, Mouse => sub { my $x = PlainMouse->new(foo => 23) }, ClassAccessorFast => sub { my $x = ClassAccessorFast->new({foo => 23}) }, }, 'noc'); vs_caf_w_destructors.pl000644000765000024 165412245117717 20651 0ustar00gfxstaff000000000000Mouse-2.1.0/benchmarks#!perl ### MODULES { package PlainMoose; use Moose; has foo => (is => 'rw'); sub DEMOLISH { } __PACKAGE__->meta->make_immutable(); } { package PlainMouse; use Mouse; has foo => (is => 'rw'); sub DEMOLISH { } __PACKAGE__->meta->make_immutable(); } { package ClassAccessorFast; use warnings; use strict; use base 'Class::Accessor::Fast'; __PACKAGE__->mk_accessors(qw(foo)); sub DESTROY { } } use Benchmark qw(cmpthese); my $moose = PlainMoose->new; my $mouse = PlainMouse->new; my $caf = ClassAccessorFast->new; print "\nCREATION AND DESTRUCTION\n"; cmpthese(-1, { Moose => sub { my $x = PlainMoose->new(foo => 23) }, Mouse => sub { my $x = PlainMouse->new(foo => 23) }, ClassAccessorFast => sub { my $x = ClassAccessorFast->new({foo => 23}) }, }, 'noc'); MyBuilder.pm000644000765000024 402612245117717 15623 0ustar00gfxstaff000000000000Mouse-2.1.0/builderpackage builder::MyBuilder; use strict; use warnings; use utf8; use 5.008_001; use base qw(Module::Build::XSUtil); sub new { my ($class, %args) = @_; $class->SUPER::new( %args, conflicts => { 'Any::Moose', '< 0.10', 'MouseX::AttributeHelpers', '< 0.06', 'MouseX::NativeTraits', '< 1.00', }, generate_ppport_h => 'ppport.h', generate_xshelper_h => 'xshelper.h', xs_files => { 'xs-src/Mouse.xs' => 'lib/Mouse.xs', }, c_source => [ 'xs-src' ], include_dirs => ['.'], ); } sub ACTION_code { my ($class) = @_; system($^X, 'tool/generate-mouse-tiny.pl', 'lib/Mouse/Tiny.pm') == 0 or warn "Cannot generate Mouse::Tiny: $!"; unless ($class->pureperl_only) { require ExtUtils::ParseXS; for my $xs (qw( xs-src/MouseAccessor.xs xs-src/MouseAttribute.xs xs-src/MouseTypeConstraints.xs xs-src/MouseUtil.xs )) { (my $c = $xs) =~ s/\.xs\z/.c/; print "$xs => $c\n"; ExtUtils::ParseXS::process_file( filename => $xs, output => $c, ); } } $class->SUPER::ACTION_code(); } sub ACTION_test { my ($class) = @_; if ($ENV{COMPAT_TEST}) { $class->depends_on('moose_compat_test'); } if ($class->pureperl_only) { print "pureperl only tests.\n"; $class->SUPER::ACTION_test(); } else { { print "xs tests.\n"; local $ENV{MOUSE_XS} = 1; $class->SUPER::ACTION_test(); } { print "pp tests.\n"; local $ENV{PERL_ONLY} = 1; $class->SUPER::ACTION_test(); } } } sub ACTION_moose_compat_test { my $class = shift; $class->depends_on('code'); system($^X, 'tool/create-moose-compatibility-tests.pl') == 0 or warn "tool/create-moose-compatibility-tests.pl: $!"; } 1; cpanfile000644000765000024 204512245117717 13446 0ustar00gfxstaff000000000000Mouse-2.1.0requires 'perl', '5.8.1'; # Scalar::Util < 1.14 has a bug. # > Fixed looks_like_number(undef) to return false for perl >= 5.009002 requires 'Scalar::Util', '1.14'; requires 'XSLoader', '0.02'; on configure => sub { requires 'Devel::PPPort', '3.19'; requires 'ExtUtils::ParseXS', '3.22'; requires 'Module::Build::XSUtil'; }; on 'test' => sub { requires 'Test::More', '0.88'; # Comes from author/cpanm.requires requires 'Test::Exception'; requires 'Test::Exception::LessClever'; requires 'Test::Fatal'; requires 'Test::LeakTrace'; requires 'Test::Output'; requires 'Test::Requires'; requires 'Try::Tiny'; }; on 'develop' => sub { # author's tests requires 'Test::Pod::Coverage'; requires 'Test::DependentModules'; # required by recipes and examples suggests 'Regexp::Common'; suggests 'Locale::US'; suggests 'HTTP::Headers'; suggests 'Params::Coerce'; suggests 'URI'; suggests 'Declare::Constraints::Simple'; suggests 'Test::Deep'; suggests 'IO::String'; }; point.pl000644000765000024 137312245117717 15066 0ustar00gfxstaff000000000000Mouse-2.1.0/example#!perl package Point; use Mouse; 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 Mouse; 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); print "point1: ", $point1->dump(); print "point2: ", $point2->dump(); print "point3: ", $point3d->dump(); print "point3d->clear()\n"; $point3d->clear(); print "point3: ", $point3d->dump(); traits.pl000644000765000024 65512245117717 15225 0ustar00gfxstaff000000000000Mouse-2.1.0/example#!perl package IntStack; use Mouse; has storage => ( is => 'ro', isa => 'ArrayRef[Int]', default => sub{ [] }, traits => [qw(Array)], handles => { push => 'push', pop => 'pop', top => [ get => -1 ], }, ); __PACKAGE__->meta->make_immutable(); package main; my $stack = IntStack->new; $stack->push(42); $stack->push(27); print $stack->pop, "\n"; print $stack->top, "\n"; warns.pl000644000765000024 71712245117717 15050 0ustar00gfxstaff000000000000Mouse-2.1.0/example#!perl package Point; use Mouse; use MouseX::StrictConstructor; # extra 'unknown_attr' is supplied (WARN) has 'x' => (isa => 'Int', is => 'rw', required => 1, unknown_attr => 1); # mandatory 'is' is not supplied (WARN) has 'y' => (isa => 'Int', required => 1); sub clear { my $self = shift; $self->x(0); $self->y(0); } __PACKAGE__->meta->make_immutable(); package main; # extra 'z' is supplied (FATAL) my $point1 = Point->new(x => 5, y => 7, z => 9); Mouse.pm000644000765000024 2752612245117717 14171 0ustar00gfxstaff000000000000Mouse-2.1.0/libpackage Mouse; use 5.006_002; use Mouse::Exporter; # enables strict and warnings our $VERSION = '2.1.0'; use Carp (); use Scalar::Util (); use Mouse::Util (); use Mouse::Meta::Module; use Mouse::Meta::Class; use Mouse::Meta::Role; use Mouse::Meta::Attribute; use Mouse::Object; use Mouse::Util::TypeConstraints (); Mouse::Exporter->setup_import_methods( as_is => [qw( extends with has before after around override super augment inner ), \&Scalar::Util::blessed, \&Carp::confess, ], ); sub extends { Mouse::Meta::Class->initialize(scalar caller)->superclasses(@_); return; } sub with { Mouse::Util::apply_all_roles(scalar(caller), @_); return; } sub has { my $meta = Mouse::Meta::Class->initialize(scalar caller); my $name = shift; $meta->throw_error(q{Usage: has 'name' => ( key => value, ... )}) if @_ % 2; # odd number of arguments for my $n(ref($name) ? @{$name} : $name){ $meta->add_attribute($n => @_); } return; } sub before { my $meta = Mouse::Meta::Class->initialize(scalar caller); my $code = pop; for my $name($meta->_collect_methods(@_)) { $meta->add_before_method_modifier($name => $code); } return; } sub after { my $meta = Mouse::Meta::Class->initialize(scalar caller); my $code = pop; for my $name($meta->_collect_methods(@_)) { $meta->add_after_method_modifier($name => $code); } return; } sub around { my $meta = Mouse::Meta::Class->initialize(scalar caller); my $code = pop; for my $name($meta->_collect_methods(@_)) { $meta->add_around_method_modifier($name => $code); } return; } our $SUPER_PACKAGE; our $SUPER_BODY; our @SUPER_ARGS; sub super { # This check avoids a recursion loop - see # t/100_bugs/020_super_recursion.t return if defined $SUPER_PACKAGE && $SUPER_PACKAGE ne caller(); return if !defined $SUPER_BODY; $SUPER_BODY->(@SUPER_ARGS); } sub override { # my($name, $method) = @_; Mouse::Meta::Class->initialize(scalar caller)->add_override_method_modifier(@_); } our %INNER_BODY; our %INNER_ARGS; sub inner { my $pkg = caller(); 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($name, $method) = @_; Mouse::Meta::Class->initialize(scalar caller)->add_augment_method_modifier(@_); return; } sub init_meta { shift; my %args = @_; my $class = $args{for_class} or confess("Cannot call init_meta without specifying a for_class"); my $base_class = $args{base_class} || 'Mouse::Object'; my $metaclass = $args{metaclass} || 'Mouse::Meta::Class'; my $meta = $metaclass->initialize($class); $meta->add_method(meta => sub{ return $metaclass->initialize(ref($_[0]) || $_[0]); }); $meta->superclasses($base_class) unless $meta->superclasses; # make a class type for each Mouse class Mouse::Util::TypeConstraints::class_type($class) unless Mouse::Util::TypeConstraints::find_type_constraint($class); return $meta; } 1; __END__ =head1 NAME Mouse - Moose minus the antlers =head1 VERSION This document describes Mouse version 2.1.0 =head1 SYNOPSIS package Point; use Mouse; # automatically turns on strict and warnings has 'x' => (is => 'rw', isa => 'Int'); has 'y' => (is => 'rw', isa => 'Int'); sub clear { my($self) = @_; $self->x(0); $self->y(0); } __PACKAGE__->meta->make_immutable(); package Point3D; use Mouse; extends 'Point'; has 'z' => (is => 'rw', isa => 'Int'); after 'clear' => sub { my($self) = @_; $self->z(0); }; __PACKAGE__->meta->make_immutable(); =head1 DESCRIPTION L is a postmodern object system for Perl5. Moose is wonderful. Unfortunately, Moose has a compile-time penalty. Though significant progress has been made over the years, the compile time penalty is a non-starter for some very specific applications. If you are writing a command-line application or CGI script where startup time is essential, you may not be able to use Moose (we recommend that you instead use persistent Perl executing environments like C for the latter, if possible). Mouse is a Moose compatible object system, which aims to alleviate this penalty by providing a subset of Moose's functionality. We're also going as light on dependencies as possible. Mouse currently has B except for building/testing modules. Mouse also works without XS, although it has an XS backend to make it much faster. =head2 Moose Compatibility Compatibility with Moose has been the utmost concern. The sugary interface is highly compatible with Moose. Even the error messages are taken from Moose. The Mouse code just runs its test suite 4x faster. The idea is that, if you need the extra power, you should be able to run C on your codebase and have nothing break. To that end, we have written L which will act as Mouse unless Moose is loaded, in which case it will act as Moose. Since Mouse is a little sloppier than Moose, if you run into weird errors, it would be worth running: ANY_MOOSE=Moose perl your-script.pl to see if the bug is caused by Mouse. Moose's diagnostics and validation are also better. See also L for compatibility and incompatibility with Moose. =head2 Mouse Extentions Please don't copy MooseX code to MouseX. If you need extensions, you really should upgrade to Moose. We don't need two parallel sets of extensions! If you really must write a Mouse extension, please contact the Moose mailing list or #moose on IRC beforehand. =head1 KEYWORDS =head2 C<< $object->meta -> Mouse::Meta::Class >> Returns this class' metaclass instance. =head2 C<< extends superclasses >> Sets this class' superclasses. =head2 C<< before (method|methods|regexp) => CodeRef >> Installs a "before" method modifier. See L. =head2 C<< after (method|methods|regexp) => CodeRef >> Installs an "after" method modifier. See L. =head2 C<< around (method|methods|regexp) => CodeRef >> Installs an "around" method modifier. See L. =head2 C<< has (name|names) => parameters >> Adds an attribute (or if passed an arrayref of names, multiple attributes) to this class. Options: =over 4 =item C<< is => ro|rw|bare >> The I option accepts either I (for read/write), I (for read only) or I (for nothing). 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 C, C and C options, however if you use those, you won't need the I option. =item C<< isa => TypeName | ClassName >> Provides type checking in the constructor and accessor. The following types are supported. Any unknown type is taken to be a class check (e.g. C<< isa => 'DateTime' >> would accept only L objects). Any Item Bool Undef Defined Value Num Int Str ClassName Ref ScalarRef ArrayRef HashRef CodeRef RegexpRef GlobRef FileHandle Object For more documentation on type constraints, see L. =item C<< does => RoleName >> This will accept the name of a role which the value stored in this attribute is expected to have consumed. =item C<< coerce => Bool >> This will attempt to use coercion with the supplied type constraint to change the value passed into any accessors or constructors. You B have supplied a type constraint in order for this to work. See L for an example. =item C<< required => Bool >> Whether this attribute is required to have a value. If the attribute is lazy or has a builder, then providing a value for the attribute in the constructor is optional. =item C<< init_arg => Str | Undef >> Allows you to use a different key name in the constructor. If undef, the attribute can't be passed to the constructor. =item C<< default => Value | CodeRef >> Sets the default value of the attribute. If the default is a coderef, it will be invoked to get the default value. Due to quirks of Perl, any bare reference is forbidden, you must wrap the reference in a coderef. Otherwise, all instances will share the same reference. =item C<< lazy => Bool >> If specified, the default is calculated on demand instead of in the constructor. =item C<< predicate => Str >> Lets you specify a method name for installing a predicate method, which checks that the attribute has a value. It will not invoke a lazy default or builder method. =item C<< clearer => Str >> Lets you specify a method name for installing a clearer method, which clears the attribute's value from the instance. On the next read, lazy or builder will be invoked. =item C<< handles => HashRef|ArrayRef|Regexp >> Lets you specify methods to delegate to the attribute. ArrayRef forwards the given method names to method calls on the attribute. HashRef maps local method names to remote method names called on the attribute. Other forms of L, such as RoleName and CodeRef, are not yet supported. =item C<< weak_ref => Bool >> Lets you automatically weaken any reference stored in the attribute. Use of this feature requires L! =item C<< trigger => CodeRef >> Any time the attribute's value is set (either through the accessor or the constructor), the trigger is called on it. The trigger receives as arguments the instance, and the new value. =item C<< builder => Str >> Defines a method name to be called to provide the default value of the attribute. C<< builder => 'build_foo' >> is mostly equivalent to C<< default => sub { $_[0]->build_foo } >>. =item C<< auto_deref => Bool >> Allows you to automatically dereference ArrayRef and HashRef attributes in list context. In scalar context, the reference is returned (NOT the list length or bucket status). You must specify an appropriate type constraint to use auto_deref. =item C<< lazy_build => Bool >> Automatically define the following options: has $attr => ( # ... lazy => 1 builder => "_build_$attr", clearer => "clear_$attr", predicate => "has_$attr", ); =back =head2 C<< confess(message) -> BOOM >> L for your convenience. =head2 C<< blessed(value) -> ClassName | undef >> L for your convenience. =head1 MISC =head2 import Importing Mouse will default your class' superclass list to L. You may use L to replace the superclass list. =head2 unimport Please unimport Mouse (C) so that if someone calls one of the keywords (such as L) it will break loudly instead breaking subtly. =head1 SOURCE CODE ACCESS We have a public git repository L:. git clone git://github.com/gfx/p5-Mouse.git =head1 DEPENDENCIES Perl 5.6.2 or later. =head1 SEE ALSO L L L L L L L =head1 AUTHORS Shawn M Moore Esartak at gmail.comE Yuval Kogman Enothingmuch at woobling.orgE tokuhirom Yappo wu-lee Goro Fuji (gfx) Egfuji@cpan.orgE with plenty of code borrowed from L and L =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 =head1 COPYRIGHT AND LICENSE Copyright (c) 2008-2010 Infinity Interactive, Inc. http://www.iinteractive.com/ This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut Exporter.pm000644000765000024 2075112245117717 15772 0ustar00gfxstaff000000000000Mouse-2.1.0/lib/Mousepackage Mouse::Exporter; use strict; use warnings; use Carp (); my %SPEC; my $strict_bits; my $warnings_extra_bits; BEGIN{ $strict_bits = strict::bits(qw(subs refs vars)); $warnings_extra_bits = warnings::bits(FATAL => 'recursion'); } # it must be "require", because Mouse::Util depends on Mouse::Exporter, # which depends on Mouse::Util::import() require Mouse::Util; sub import{ ## no critic ProhibitBitwiseOperators # strict->import; $^H |= $strict_bits; # warnings->import('all', FATAL => 'recursion'); ${^WARNING_BITS} |= $warnings::Bits{all}; ${^WARNING_BITS} |= $warnings_extra_bits; return; } sub setup_import_methods{ my($class, %args) = @_; my $exporting_package = $args{exporting_package} ||= caller(); my($import, $unimport) = $class->build_import_methods(%args); Mouse::Util::install_subroutines($exporting_package, import => $import, unimport => $unimport, export_to_level => sub { my($package, $level, undef, @args) = @_; # the third argument is redundant $package->import({ into_level => $level + 1 }, @args); }, export => sub { my($package, $into, @args) = @_; $package->import({ into => $into }, @args); }, ); return; } sub build_import_methods{ my($self, %args) = @_; my $exporting_package = $args{exporting_package} ||= caller(); $SPEC{$exporting_package} = \%args; # canonicalize args my @export_from; if($args{also}){ my %seen; my @stack = ($exporting_package); while(my $current = shift @stack){ push @export_from, $current; my $also = $SPEC{$current}{also} or next; push @stack, grep{ !$seen{$_}++ } ref($also) ? @{ $also } : $also; } } else{ @export_from = ($exporting_package); } my %exports; my @removables; my @all; my @init_meta_methods; foreach my $package(@export_from){ my $spec = $SPEC{$package} or next; if(my $as_is = $spec->{as_is}){ foreach my $thingy (@{$as_is}){ my($code_package, $code_name, $code); if(ref($thingy)){ $code = $thingy; ($code_package, $code_name) = Mouse::Util::get_code_info($code); } else{ $code_package = $package; $code_name = $thingy; no strict 'refs'; $code = \&{ $code_package . '::' . $code_name }; } push @all, $code_name; $exports{$code_name} = $code; if($code_package eq $package){ push @removables, $code_name; } } } if(my $init_meta = $package->can('init_meta')){ if(!grep{ $_ == $init_meta } @init_meta_methods){ push @init_meta_methods, $init_meta; } } } $args{EXPORTS} = \%exports; $args{REMOVABLES} = \@removables; $args{groups}{all} ||= \@all; if(my $default_list = $args{groups}{default}){ my %default; foreach my $keyword(@{$default_list}){ $default{$keyword} = $exports{$keyword} || Carp::confess(qq{The $exporting_package package does not export "$keyword"}); } $args{DEFAULT} = \%default; } else{ $args{groups}{default} ||= \@all; $args{DEFAULT} = $args{EXPORTS}; } if(@init_meta_methods){ $args{INIT_META} = \@init_meta_methods; } return (\&do_import, \&do_unimport); } # the entity of general import() sub do_import { my($package, @args) = @_; my $spec = $SPEC{$package} || Carp::confess("The package $package package does not use Mouse::Exporter"); my $into = _get_caller_package(ref($args[0]) ? shift @args : undef); my @exports; my @traits; while(@args){ my $arg = shift @args; if($arg =~ s/^-//){ if($arg eq 'traits'){ push @traits, ref($args[0]) ? @{shift(@args)} : shift(@args); } else { Mouse::Util::not_supported("-$arg"); } } elsif($arg =~ s/^://){ my $group = $spec->{groups}{$arg} || Carp::confess(qq{The $package package does not export the group "$arg"}); push @exports, @{$group}; } else{ push @exports, $arg; } } # strict->import; $^H |= $strict_bits; ## no critic ProhibitBitwiseOperators # warnings->import('all', FATAL => 'recursion'); ${^WARNING_BITS} |= $warnings::Bits{all}; ## no critic ProhibitBitwiseOperators ${^WARNING_BITS} |= $warnings_extra_bits; ## no critic ProhibitBitwiseOperators if($spec->{INIT_META}){ my $meta; foreach my $init_meta(@{$spec->{INIT_META}}){ $meta = $package->$init_meta(for_class => $into); } if(@traits){ my $type = (split /::/, ref $meta)[-1]; # e.g. "Class" for "My::Meta::Class" @traits = map{ ref($_) ? $_ : Mouse::Util::resolve_metaclass_alias($type => $_, trait => 1) } @traits; require Mouse::Util::MetaRole; Mouse::Util::MetaRole::apply_metaroles( for => $into, Mouse::Util::is_a_metarole($into->meta) ? (role_metaroles => { role => \@traits }) : (class_metaroles => { class => \@traits }), ); } } elsif(@traits){ Carp::confess("Cannot provide traits when $package does not have an init_meta() method"); } if(@exports){ my @export_table; foreach my $keyword(@exports){ push @export_table, $keyword => ($spec->{EXPORTS}{$keyword} || Carp::confess(qq{The $package package does not export "$keyword"}) ); } Mouse::Util::install_subroutines($into, @export_table); } else{ Mouse::Util::install_subroutines($into, %{$spec->{DEFAULT}}); } return; } # the entity of general unimport() sub do_unimport { my($package, $arg) = @_; my $spec = $SPEC{$package} || Carp::confess("The package $package does not use Mouse::Exporter"); my $from = _get_caller_package($arg); my $stash = do{ no strict 'refs'; \%{$from . '::'} }; for my $keyword (@{ $spec->{REMOVABLES} }) { next if !exists $stash->{$keyword}; my $gv = \$stash->{$keyword}; # remove what is from us if(ref($gv) eq 'GLOB' && *{$gv}{CODE} == $spec->{EXPORTS}{$keyword}){ delete $stash->{$keyword}; } } return; } sub _get_caller_package { my($arg) = @_; # We need one extra level because it's called by import so there's a layer # of indirection if(ref $arg){ return defined($arg->{into}) ? $arg->{into} : defined($arg->{into_level}) ? scalar caller(1 + $arg->{into_level}) : scalar caller(1); } else{ return scalar caller(1); } } 1; __END__ =head1 NAME Mouse::Exporter - make an import() and unimport() just like Mouse.pm =head1 VERSION This document describes Mouse version 2.1.0 =head1 SYNOPSIS package MyApp::Mouse; use Mouse (); use Mouse::Exporter; Mouse::Exporter->setup_import_methods( as_is => [ 'has_rw', 'other_sugar', \&Some::Random::thing ], also => 'Mouse', ); sub has_rw { my $meta = caller->meta; my ( $name, %options ) = @_; $meta->add_attribute( $name, is => 'rw', %options, ); } # then later ... package MyApp::User; use MyApp::Mouse; has 'name'; has_rw 'size'; thing; no MyApp::Mouse; =head1 DESCRIPTION This module encapsulates the exporting of sugar functions in a C-like manner. It does this by building custom C, C methods for your module, based on a spec you provide. Note that C does not provide the C option, but you can easily get the metaclass by C<< caller->meta >> as L shows. =head1 METHODS =head2 C<< setup_import_methods( ARGS ) >> =head2 C<< build_import_methods( ARGS ) -> (\&import, \&unimport) >> =head1 SEE ALSO L =cut Attribute.pm000644000765000024 3212112245117717 17005 0ustar00gfxstaff000000000000Mouse-2.1.0/lib/Mouse/Metapackage Mouse::Meta::Attribute; use Mouse::Util qw(:meta); # enables strict and warnings use Carp (); use Mouse::Meta::TypeConstraint; my %valid_options = map { $_ => undef } ( 'accessor', 'auto_deref', 'builder', 'clearer', 'coerce', 'default', 'documentation', 'does', 'handles', 'init_arg', 'insertion_order', 'is', 'isa', 'lazy', 'lazy_build', 'name', 'predicate', 'reader', 'required', 'traits', 'trigger', 'type_constraint', 'weak_ref', 'writer', # internally used 'associated_class', 'associated_methods', '__METACLASS__', # Moose defines, but Mouse doesn't #'definition_context', #'initializer', # special case for AttributeHelpers 'provides', 'curries', ); our @CARP_NOT = qw(Mouse::Meta::Class); sub new { my $class = shift; my $name = shift; my $args = $class->Mouse::Object::BUILDARGS(@_); $class->_process_options($name, $args); $args->{name} = $name; # check options # (1) known by core my @bad = grep{ !exists $valid_options{$_} } keys %{$args}; # (2) known by subclasses if(@bad && $class ne __PACKAGE__){ my %valid_attrs = ( map { $_ => undef } grep { defined } map { $_->init_arg() } $class->meta->get_all_attributes() ); @bad = grep{ !exists $valid_attrs{$_} } @bad; } # (3) bad options found if(@bad){ Carp::carp( "Found unknown argument(s) passed to '$name' attribute constructor in '$class': " . Mouse::Util::english_list(@bad)); } my $self = bless $args, $class; if($class ne __PACKAGE__){ $class->meta->_initialize_object($self, $args); } return $self; } sub has_read_method { $_[0]->has_reader || $_[0]->has_accessor } sub has_write_method { $_[0]->has_writer || $_[0]->has_accessor } sub get_read_method { $_[0]->reader || $_[0]->accessor } sub get_write_method { $_[0]->writer || $_[0]->accessor } sub get_read_method_ref{ my($self) = @_; return $self->{_mouse_cache_read_method_ref} ||= $self->_get_accessor_method_ref('get_read_method', '_generate_reader'); } sub get_write_method_ref{ my($self) = @_; return $self->{_mouse_cache_write_method_ref} ||= $self->_get_accessor_method_ref('get_write_method', '_generate_writer'); } sub interpolate_class{ my($class, $args) = @_; if(my $metaclass = delete $args->{metaclass}){ $class = Mouse::Util::resolve_metaclass_alias( Attribute => $metaclass ); } my @traits; if(my $traits_ref = delete $args->{traits}){ for (my $i = 0; $i < @{$traits_ref}; $i++) { my $trait = Mouse::Util::resolve_metaclass_alias(Attribute => $traits_ref->[$i], trait => 1); next if $class->does($trait); push @traits, $trait; # are there options? push @traits, $traits_ref->[++$i] if ref($traits_ref->[$i+1]); } if (@traits) { $class = Mouse::Meta::Class->create_anon_class( superclasses => [ $class ], roles => \@traits, cache => 1, )->name; } } return( $class, @traits ); } sub verify_against_type_constraint { my ($self, $value) = @_; my $type_constraint = $self->{type_constraint}; return 1 if !$type_constraint; return 1 if $type_constraint->check($value); $self->_throw_type_constraint_error($value, $type_constraint); } sub _throw_type_constraint_error { my($self, $value, $type) = @_; $self->throw_error( sprintf q{Attribute (%s) does not pass the type constraint because: %s}, $self->name, $type->get_message($value), ); } sub illegal_options_for_inheritance { return qw(reader writer accessor clearer predicate); } sub clone_and_inherit_options{ my $self = shift; my $args = $self->Mouse::Object::BUILDARGS(@_); foreach my $illegal($self->illegal_options_for_inheritance) { if(exists $args->{$illegal} and exists $self->{$illegal}) { $self->throw_error("Illegal inherited option: $illegal"); } } foreach my $name(keys %{$self}){ if(!exists $args->{$name}){ $args->{$name} = $self->{$name}; # inherit from self } } my($attribute_class, @traits) = ref($self)->interpolate_class($args); $args->{traits} = \@traits if @traits; # remove temporary caches foreach my $attr(keys %{$args}){ if($attr =~ /\A _mouse_cache_/xms){ delete $args->{$attr}; } } # remove default if lazy_build => 1 if($args->{lazy_build}) { delete $args->{default}; } return $attribute_class->new($self->name, $args); } sub _get_accessor_method_ref { my($self, $type, $generator) = @_; my $metaclass = $self->associated_class || $self->throw_error('No asocciated class for ' . $self->name); my $accessor = $self->$type(); if($accessor){ return $metaclass->get_method_body($accessor); } else{ return $self->accessor_metaclass->$generator($self, $metaclass); } } sub set_value { my($self, $object, $value) = @_; return $self->get_write_method_ref()->($object, $value); } sub get_value { my($self, $object) = @_; return $self->get_read_method_ref()->($object); } sub has_value { my($self, $object) = @_; my $accessor_ref = $self->{_mouse_cache_predicate_ref} ||= $self->_get_accessor_method_ref('predicate', '_generate_predicate'); return $accessor_ref->($object); } sub clear_value { my($self, $object) = @_; my $accessor_ref = $self->{_mouse_cache_crealer_ref} ||= $self->_get_accessor_method_ref('clearer', '_generate_clearer'); return $accessor_ref->($object); } sub associate_method{ #my($attribute, $method_name) = @_; my($attribute) = @_; $attribute->{associated_methods}++; return; } sub install_accessors{ my($attribute) = @_; my $metaclass = $attribute->associated_class; my $accessor_class = $attribute->accessor_metaclass; foreach my $type(qw(accessor reader writer predicate clearer)){ if(exists $attribute->{$type}){ my $generator = '_generate_' . $type; my $code = $accessor_class->$generator($attribute, $metaclass); my $name = $attribute->{$type}; # TODO: do something for compatibility # if( $metaclass->name->can($name) ) { # my $t = $metaclass->has_method($name) ? 'method' : 'function'; # Carp::cluck("You are overwriting a locally defined $t" # . " ($name) with an accessor"); # } $metaclass->add_method($name => $code); $attribute->associate_method($name); } } # install delegation if(exists $attribute->{handles}){ my %handles = $attribute->_canonicalize_handles(); while(my($handle, $method_to_call) = each %handles){ next if Mouse::Object->can($handle); if($metaclass->has_method($handle)) { $attribute->throw_error("You cannot overwrite a locally defined method ($handle) with a delegation"); } $metaclass->add_method($handle => $attribute->_make_delegation_method( $handle, $method_to_call)); $attribute->associate_method($handle); } } return; } sub delegation_metaclass() { ## no critic 'Mouse::Meta::Method::Delegation' } sub _canonicalize_handles { my($self) = @_; my $handles = $self->{handles}; 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') { my $meta = $self->_find_delegate_metaclass(); return map { $_ => $_ } grep { /$handles/ } Mouse::Util::is_a_metarole($meta) ? $meta->get_method_list : $meta->get_all_method_names; } elsif ($handle_type eq 'CODE') { return $handles->( $self, $self->_find_delegate_metaclass() ); } else { $self->throw_error("Unable to canonicalize the 'handles' option with $handles"); } } sub _find_delegate_metaclass { my($self) = @_; my $meta; if($self->{isa}) { $meta = Mouse::Meta::Class->initialize("$self->{isa}"); } elsif($self->{does}) { $meta = Mouse::Util::get_metaclass_by_name("$self->{does}"); } defined($meta) or $self->throw_error( "Cannot find delegate metaclass for attribute " . $self->name); return $meta; } sub _make_delegation_method { my($self, $handle, $method_to_call) = @_; return Mouse::Util::load_class($self->delegation_metaclass) ->_generate_delegation($self, $handle, $method_to_call); } 1; __END__ =head1 NAME Mouse::Meta::Attribute - The Mouse attribute metaclass =head1 VERSION This document describes Mouse version 2.1.0 =head1 DESCRIPTION This is a meta object protocol for Mouse attributes, which is a subset of Moose::Meta::Attribute. =head1 METHODS =head2 C<< new(%options) -> Mouse::Meta::Attribute >> Instantiates a new Mouse::Meta::Attribute. Does nothing else. It adds the following options to the constructor: =over 4 =item C<< 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 C<< 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 C<< does => Role >> This is short-hand for saying that the attribute's type must be an object which does the named role. B =item C<< coerce => Bool >> This option is only valid for objects with a type constraint (C). 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 C<< trigger => CodeRef >> This option accepts a subroutine reference, which will be called after the attribute is set. =item C<< 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 C<< 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 C<< weak_ref => Bool >> If this is true, the attribute's value will be stored as a weak reference. =item C<< 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 C<< 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', ); =back =head2 C<< associate_method(MethodName) >> Associates a method with the attribute. Typically, this is called internally when an attribute generates its accessors. Currently the argument I is ignored in Mouse. =head2 C<< verify_against_type_constraint(Item) -> TRUE | ERROR >> Checks that the given value passes this attribute's type constraint. Returns C on success, otherwise Ces. =head2 C<< clone_and_inherit_options(options) -> Mouse::Meta::Attribute >> Creates a new attribute in the owner class, inheriting options from parent classes. Accessors and helper methods are installed. Some error checking is done. =head2 C<< get_read_method_ref >> =head2 C<< 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. =head1 SEE ALSO L L =cut Class.pm000644000765000024 3603712245117717 16121 0ustar00gfxstaff000000000000Mouse-2.1.0/lib/Mouse/Metapackage Mouse::Meta::Class; use Mouse::Util qw/:meta/; # enables strict and warnings use Scalar::Util (); use Mouse::Meta::Module; our @ISA = qw(Mouse::Meta::Module); our @CARP_NOT = qw(Mouse); # trust Mouse sub attribute_metaclass; sub method_metaclass; sub constructor_class; sub destructor_class; sub _construct_meta { my($class, %args) = @_; $args{attributes} = {}; $args{methods} = {}; $args{roles} = []; $args{superclasses} = do { no strict 'refs'; \@{ $args{package} . '::ISA' }; }; my $self = bless \%args, ref($class) || $class; if(ref($self) ne __PACKAGE__){ $self->meta->_initialize_object($self, \%args); } return $self; } sub create_anon_class{ my $self = shift; return $self->create(undef, @_); } sub is_anon_class; sub roles; sub calculate_all_roles { my $self = shift; my %seen; return grep { !$seen{ $_->name }++ } map { $_->calculate_all_roles } @{ $self->roles }; } sub superclasses { my $self = shift; if (@_) { foreach my $super(@_){ Mouse::Util::load_class($super); my $meta = Mouse::Util::get_metaclass_by_name($super); next if $self->verify_superclass($super, $meta); $self->_reconcile_with_superclass_meta($meta); } return @{ $self->{superclasses} } = @_; } return @{ $self->{superclasses} }; } sub verify_superclass { my($self, $super, $super_meta) = @_; if(defined $super_meta) { if(Mouse::Util::is_a_metarole($super_meta)){ $self->throw_error("You cannot inherit from a Mouse Role ($super)"); } } else { # The metaclass of $super is not initialized. # i.e. it might be Mouse::Object, a mixin package (e.g. Exporter), # or a foreign class including Moose classes. # See also Mouse::Foreign::Meta::Role::Class. my $mm = $super->can('meta'); if(!($mm && $mm == \&Mouse::Util::meta)) { if($super->can('new') or $super->can('DESTROY')) { $self->inherit_from_foreign_class($super); } } return 1; # always ok } return $self->isa(ref $super_meta); # checks metaclass compatibility } sub inherit_from_foreign_class { my($class, $super) = @_; if($ENV{PERL_MOUSE_STRICT}) { Carp::carp("You inherit from non-Mouse class ($super)," . " but it is unlikely to work correctly." . " Please consider using MouseX::Foreign"); } return; } my @MetaClassTypes = ( 'attribute', # Mouse::Meta::Attribute 'method', # Mouse::Meta::Method 'constructor', # Mouse::Meta::Method::Constructor 'destructor', # Mouse::Meta::Method::Destructor ); sub _reconcile_with_superclass_meta { my($self, $other) = @_; # find incompatible traits my %metaroles; foreach my $metaclass_type(@MetaClassTypes){ my $accessor = $self->can($metaclass_type . '_metaclass') || $self->can($metaclass_type . '_class'); my $other_c = $other->$accessor(); my $self_c = $self->$accessor(); if(!$self_c->isa($other_c)){ $metaroles{$metaclass_type} = [ $self_c->meta->_collect_roles($other_c->meta) ]; } } $metaroles{class} = [$self->meta->_collect_roles($other->meta)]; #use Data::Dumper; print Data::Dumper->new([\%metaroles], ['*metaroles'])->Indent(1)->Dump; require Mouse::Util::MetaRole; $_[0] = Mouse::Util::MetaRole::apply_metaroles( for => $self, class_metaroles => \%metaroles, ); return; } sub _collect_roles { my ($self, $other) = @_; # find common ancestor my @self_lin_isa = $self->linearized_isa; my @other_lin_isa = $other->linearized_isa; my(@self_anon_supers, @other_anon_supers); push @self_anon_supers, shift @self_lin_isa while $self_lin_isa[0]->meta->is_anon_class; push @other_anon_supers, shift @other_lin_isa while $other_lin_isa[0]->meta->is_anon_class; my $common_ancestor = $self_lin_isa[0] eq $other_lin_isa[0] && $self_lin_isa[0]; if(!$common_ancestor){ $self->throw_error(sprintf '%s cannot have %s as a super class because of their metaclass incompatibility', $self->name, $other->name); } my %seen; return sort grep { !$seen{$_}++ } ## no critic (map{ $_->name } map{ $_->meta->calculate_all_roles } @self_anon_supers), (map{ $_->name } map{ $_->meta->calculate_all_roles } @other_anon_supers), ; } sub find_method_by_name { my($self, $method_name) = @_; defined($method_name) or $self->throw_error('You must define a method name to find'); foreach my $class( $self->linearized_isa ){ my $method = $self->initialize($class)->get_method($method_name); return $method if defined $method; } return undef; } sub get_all_methods { my($self) = @_; return map{ $self->find_method_by_name($_) } $self->get_all_method_names; } sub get_all_method_names { my $self = shift; my %uniq; return grep { $uniq{$_}++ == 0 } map { Mouse::Meta::Class->initialize($_)->get_method_list() } $self->linearized_isa; } sub find_attribute_by_name { my($self, $name) = @_; defined($name) or $self->throw_error('You must define an attribute name to find'); foreach my $attr($self->get_all_attributes) { return $attr if $attr->name eq $name; } return undef; } sub add_attribute { my $self = shift; my($attr, $name); if(Scalar::Util::blessed($_[0])){ $attr = $_[0]; $attr->isa('Mouse::Meta::Attribute') || $self->throw_error("Your attribute must be an instance of Mouse::Meta::Attribute (or a subclass)"); $name = $attr->name; } else{ # _process_attribute $name = shift; my %args = (@_ == 1) ? %{$_[0]} : @_; defined($name) or $self->throw_error('You must provide a name for the attribute'); if ($name =~ s/^\+//) { # inherited attributes my $inherited_attr = $self->find_attribute_by_name($name) or $self->throw_error("Could not find an attribute by the name of '$name' to inherit from in ".$self->name); $attr = $inherited_attr->clone_and_inherit_options(%args); } else{ my($attribute_class, @traits) = $self->attribute_metaclass->interpolate_class(\%args); $args{traits} = \@traits if @traits; $attr = $attribute_class->new($name, %args); } } Scalar::Util::weaken( $attr->{associated_class} = $self ); # install accessors first $attr->install_accessors(); # then register the attribute to the metaclass $attr->{insertion_order} = keys %{ $self->{attributes} }; $self->{attributes}{$name} = $attr; $self->_invalidate_metaclass_cache(); if(!$attr->{associated_methods} && ($attr->{is} || '') ne 'bare'){ Carp::carp(qq{Attribute ($name) of class }.$self->name .qq{ has no associated methods (did you mean to provide an "is" argument?)}); } return $attr; } sub _calculate_all_attributes { my($self) = @_; my %seen; my @all_attrs; foreach my $class($self->linearized_isa) { my $meta = Mouse::Util::get_metaclass_by_name($class) or next; my @attrs = grep { !$seen{$_->name}++ } values %{$meta->{attributes}}; @attrs = sort { $b->{insertion_order} <=> $a->{insertion_order} } @attrs; push @all_attrs, @attrs; } return [reverse @all_attrs]; } sub linearized_isa; sub new_object; sub clone_object; sub immutable_options { my ( $self, @args ) = @_; return ( inline_constructor => 1, inline_destructor => 1, constructor_name => 'new', @args, ); } sub make_immutable { my $self = shift; my %args = $self->immutable_options(@_); $self->{is_immutable}++; if ($args{inline_constructor}) { $self->add_method($args{constructor_name} => Mouse::Util::load_class($self->constructor_class) ->_generate_constructor($self, \%args)); } if ($args{inline_destructor}) { $self->add_method(DESTROY => Mouse::Util::load_class($self->destructor_class) ->_generate_destructor($self, \%args)); } # Moose's make_immutable returns true allowing calling code to skip # setting an explicit true value at the end of a source file. return 1; } sub make_mutable { my($self) = @_; $self->{is_immutable} = 0; return; } sub is_immutable; sub is_mutable { !$_[0]->is_immutable } sub _install_modifier { my( $self, $type, $name, $code ) = @_; my $into = $self->name; my $original = $into->can($name) or $self->throw_error("The method '$name' was not found in the inheritance hierarchy for $into"); my $modifier_table = $self->{modifiers}{$name}; if(!$modifier_table){ my(@before, @after, @around); my $cache = $original; my $modified = sub { if(@before) { for my $c (@before) { $c->(@_) } } unless(@after) { return $cache->(@_); } if(wantarray){ # list context my @rval = $cache->(@_); for my $c(@after){ $c->(@_) } return @rval; } elsif(defined wantarray){ # scalar context my $rval = $cache->(@_); for my $c(@after){ $c->(@_) } return $rval; } else{ # void context $cache->(@_); for my $c(@after){ $c->(@_) } return; } }; $self->{modifiers}{$name} = $modifier_table = { original => $original, before => \@before, after => \@after, around => \@around, cache => \$cache, # cache for around modifiers }; $self->add_method($name => $modified); } if($type eq 'before'){ unshift @{$modifier_table->{before}}, $code; } elsif($type eq 'after'){ push @{$modifier_table->{after}}, $code; } else{ # around push @{$modifier_table->{around}}, $code; my $next = ${ $modifier_table->{cache} }; ${ $modifier_table->{cache} } = sub{ $code->($next, @_) }; } return; } sub add_before_method_modifier { my ( $self, $name, $code ) = @_; $self->_install_modifier( 'before', $name, $code ); } sub add_around_method_modifier { my ( $self, $name, $code ) = @_; $self->_install_modifier( 'around', $name, $code ); } sub add_after_method_modifier { my ( $self, $name, $code ) = @_; $self->_install_modifier( 'after', $name, $code ); } sub add_override_method_modifier { my ($self, $name, $code) = @_; if($self->has_method($name)){ $self->throw_error("Cannot add an override method if a local method is already present"); } my $package = $self->name; my $super_body = $package->can($name) or $self->throw_error("You cannot override '$name' because it has no super method"); $self->add_method($name => sub { local $Mouse::SUPER_PACKAGE = $package; local $Mouse::SUPER_BODY = $super_body; local @Mouse::SUPER_ARGS = @_; &{$code}; }); return; } sub add_augment_method_modifier { my ($self, $name, $code) = @_; if($self->has_method($name)){ $self->throw_error("Cannot add an augment method if a local method is already present"); } my $super = $self->find_method_by_name($name) or $self->throw_error("You cannot augment '$name' because it has no super method"); my $super_package = $super->package_name; my $super_body = $super->body; $self->add_method($name => sub { local $Mouse::INNER_BODY{$super_package} = $code; local $Mouse::INNER_ARGS{$super_package} = [@_]; &{$super_body}; }); return; } sub does_role { my ($self, $role_name) = @_; (defined $role_name) || $self->throw_error("You must supply a role name to look for"); $role_name = $role_name->name if ref $role_name; for my $class ($self->linearized_isa) { my $meta = Mouse::Util::get_metaclass_by_name($class) or next; for my $role (@{ $meta->roles }) { return 1 if $role->does_role($role_name); } } return 0; } 1; __END__ =head1 NAME Mouse::Meta::Class - The Mouse class metaclass =head1 VERSION This document describes Mouse version 2.1.0 =head1 DESCRIPTION This class is a meta object protocol for Mouse classes, which is a subset of Moose::Meta:::Class. =head1 METHODS =head2 C<< initialize(ClassName) -> Mouse::Meta::Class >> Finds or creates a C instance for the given ClassName. Only one instance should exist for a given class. =head2 C<< name -> ClassName >> Returns the name of the owner class. =head2 C<< superclasses -> ClassNames >> C<< superclass(ClassNames) >> Gets (or sets) the list of superclasses of the owner class. =head2 C<< add_method(name => CodeRef) >> Adds a method to the owner class. =head2 C<< has_method(name) -> Bool >> Returns whether we have a method with the given name. =head2 C<< get_method(name) -> Mouse::Meta::Method | undef >> Returns a L with the given name. Note that you can also use C<< $metaclass->name->can($name) >> for a method body. =head2 C<< get_method_list -> Names >> Returns a list of method names which are defined in the local class. If you want a list of all applicable methods for a class, use the C method. =head2 C<< get_all_methods -> (Mouse::Meta::Method) >> Return the list of all L instances associated with the class and its superclasses. =head2 C<< add_attribute(name => spec | Mouse::Meta::Attribute) >> Begins keeping track of the existing L for the owner class. =head2 C<< has_attribute(Name) -> Bool >> Returns whether we have a L with the given name. =head2 C<< get_attribute Name -> Mouse::Meta::Attribute | undef >> Returns the L with the given name. =head2 C<< get_attribute_list -> Names >> Returns a list of attribute names which are defined in the local class. If you want a list of all applicable attributes for a class, use the C method. =head2 C<< get_all_attributes -> (Mouse::Meta::Attribute) >> Returns the list of all L instances associated with this class and its superclasses. =head2 C<< linearized_isa -> [ClassNames] >> Returns the list of classes in method dispatch order, with duplicates removed. =head2 C<< new_object(Parameters) -> Instance >> Creates a new instance. =head2 C<< clone_object(Instance, Parameters) -> Instance >> Clones the given instance which must be an instance governed by this metaclass. =head2 C<< throw_error(Message, Parameters) >> Throws an error with the given message. =head1 SEE ALSO L L L =cut Method.pm000644000765000024 254012245117717 16244 0ustar00gfxstaff000000000000Mouse-2.1.0/lib/Mouse/Metapackage Mouse::Meta::Method; use Mouse::Util qw(:meta); # enables strict and warnings use Scalar::Util (); use overload '==' => '_equal', 'eq' => '_equal', '&{}' => sub{ $_[0]->body }, fallback => 1, ; sub wrap { my $class = shift; unshift @_, 'body' if @_ % 2 != 0; return $class->_new(@_); } sub _new{ my($class, %args) = @_; my $self = bless \%args, $class; if($class ne __PACKAGE__){ $self->meta->_initialize_object($self, \%args); } return $self; } sub body { $_[0]->{body} } sub name { $_[0]->{name} } sub package_name { $_[0]->{package} } sub associated_metaclass { $_[0]->{associated_metaclass} } sub fully_qualified_name { my($self) = @_; return $self->package_name . '::' . $self->name; } # for Moose compat sub _equal { my($l, $r) = @_; return Scalar::Util::blessed($r) && $l->body == $r->body && $l->name eq $r->name && $l->package_name eq $r->package_name; } 1; __END__ =head1 NAME Mouse::Meta::Method - A Mouse Method metaclass =head1 VERSION This document describes Mouse version 2.1.0 =head1 DESCRIPTION This class is a meta object protocol for Mouse methods, which is a subset of Moose::Meta:::Method. =head1 SEE ALSO L L =cut Accessor.pm000644000765000024 1261712245117717 20034 0ustar00gfxstaff000000000000Mouse-2.1.0/lib/Mouse/Meta/Methodpackage Mouse::Meta::Method::Accessor; use Mouse::Util qw(:meta); # enables strict and warnings use constant _MOUSE_DEBUG => $ENV{MOUSE_DEBUG} ? 1 : 0; sub _inline_slot{ my(undef, $self_var, $attr_name) = @_; return sprintf '%s->{q{%s}}', $self_var, $attr_name; } sub _generate_accessor_any{ my($method_class, $type, $attribute, $class) = @_; my $name = $attribute->name; my $default = $attribute->default; my $constraint = $attribute->type_constraint; my $builder = $attribute->builder; my $trigger = $attribute->trigger; my $is_weak = $attribute->is_weak_ref; my $should_deref = $attribute->should_auto_deref; my $should_coerce = (defined($constraint) && $constraint->has_coercion && $attribute->should_coerce); my $compiled_type_constraint = defined($constraint) ? $constraint->_compiled_type_constraint : undef; my $self = '$_[0]'; my $slot = $method_class->_inline_slot($self, $name);; my $accessor = sprintf(qq{package %s;\n#line 1 "%s-accessor for %s (%s)"\n}, $class->name, $type, $name, __FILE__) . "sub {\n"; if ($type eq 'rw' || $type eq 'wo') { if($type eq 'rw'){ $accessor .= 'if (scalar(@_) >= 2) {' . "\n"; } else{ # writer $accessor .= 'if(@_ < 2){ Carp::confess("Not enough arguments for the writer of $name") }'. '{' . "\n"; } my $value = '$_[1]'; if (defined $constraint) { if ($should_coerce) { $accessor .= "\n". 'my $val = $constraint->coerce('.$value.');'; $value = '$val'; } $accessor .= "\n". '$compiled_type_constraint->('.$value.') or $attribute->_throw_type_constraint_error('.$value.', $constraint);' . "\n"; } # if there's nothing left to do for the attribute we can return during # this setter $accessor .= 'return ' if !$is_weak && !$trigger && !$should_deref; $accessor .= "my \@old_value = exists $slot ? $slot : ();\n" if $trigger; $accessor .= "$slot = $value;\n"; if ($is_weak) { $accessor .= "Scalar::Util::weaken($slot) if ref $slot;\n"; } if ($trigger) { $accessor .= '$trigger->('.$self.', '.$value.', @old_value);' . "\n"; } $accessor .= "}\n"; } elsif($type eq 'ro') { $accessor .= 'Carp::confess("Cannot assign a value to a read-only accessor of $name") if scalar(@_) >= 2;' . "\n"; } else{ $class->throw_error("Unknown accessor type '$type'"); } if ($attribute->is_lazy and $type ne 'wo') { my $value; if (defined $builder){ $value = "$self->\$builder()"; } elsif (ref($default) eq 'CODE'){ $value = "$self->\$default()"; } else{ $value = '$default'; } $accessor .= "els" if $type eq 'rw'; $accessor .= "if(!exists $slot){\n"; if($should_coerce){ $accessor .= "$slot = \$constraint->coerce($value)"; } elsif(defined $constraint){ $accessor .= "my \$tmp = $value;\n"; $accessor .= "\$compiled_type_constraint->(\$tmp)"; $accessor .= " || \$attribute->_throw_type_constraint_error(\$tmp, \$constraint);\n"; $accessor .= "$slot = \$tmp;\n"; } else{ $accessor .= "$slot = $value;\n"; } if ($is_weak) { $accessor .= "Scalar::Util::weaken($slot) if ref $slot;\n"; } $accessor .= "}\n"; } if ($should_deref) { if ($constraint->is_a_type_of('ArrayRef')) { $accessor .= "return \@{ $slot || [] } if wantarray;\n"; } elsif($constraint->is_a_type_of('HashRef')){ $accessor .= "return \%{ $slot || {} } if wantarray;\n"; } else{ $class->throw_error("Can not auto de-reference the type constraint " . $constraint->name); } } $accessor .= "return $slot;\n}\n"; warn $accessor if _MOUSE_DEBUG; my $code; my $e = do{ local $@; $code = eval $accessor; $@; }; die $e if $e; return $code; } sub _generate_accessor{ #my($self, $attribute, $metaclass) = @_; my $self = shift; return $self->_generate_accessor_any(rw => @_); } sub _generate_reader { #my($self, $attribute, $metaclass) = @_; my $self = shift; return $self->_generate_accessor_any(ro => @_); } sub _generate_writer { #my($self, $attribute, $metaclass) = @_; my $self = shift; return $self->_generate_accessor_any(wo => @_); } sub _generate_predicate { #my($self, $attribute, $metaclass) = @_; my(undef, $attribute) = @_; my $slot = $attribute->name; return sub{ return exists $_[0]->{$slot}; }; } sub _generate_clearer { #my($self, $attribute, $metaclass) = @_; my(undef, $attribute) = @_; my $slot = $attribute->name; return sub{ delete $_[0]->{$slot}; }; } 1; __END__ =head1 NAME Mouse::Meta::Method::Accessor - A Mouse method generator for accessors =head1 VERSION This document describes Mouse version 2.1.0 =head1 SEE ALSO L =cut Constructor.pm000644000765000024 1470012245117717 20612 0ustar00gfxstaff000000000000Mouse-2.1.0/lib/Mouse/Meta/Methodpackage Mouse::Meta::Method::Constructor; use Mouse::Util qw(:meta); # enables strict and warnings use constant _MOUSE_DEBUG => $ENV{MOUSE_DEBUG} ? 1 : 0; sub _inline_slot{ my(undef, $self_var, $attr_name) = @_; return sprintf '%s->{q{%s}}', $self_var, $attr_name; } sub _generate_constructor { my ($class, $metaclass, $args) = @_; my $associated_metaclass_name = $metaclass->name; my $buildall = $class->_generate_BUILDALL($metaclass); my $buildargs = $class->_generate_BUILDARGS($metaclass); my $initializer = $metaclass->{_mouse_cache}{_initialize_object} ||= $class->_generate_initialize_object($metaclass); my $source = sprintf(<<'EOT', __FILE__, $metaclass->name, $buildargs, $buildall); #line 1 "%s" package %s; sub { my $class = shift; return $class->Mouse::Object::new(@_) if $class ne __PACKAGE__; # BUILDARGS %s; my $instance = bless {}, $class; $metaclass->$initializer($instance, $args, 0); # BUILDALL %s; return $instance; } EOT warn $source if _MOUSE_DEBUG; my $body; my $e = do{ local $@; $body = eval $source; $@; }; die $e if $e; return $body; } sub _generate_initialize_object { my ($method_class, $metaclass) = @_; my @attrs = $metaclass->get_all_attributes; my @checks = map { $_ && $_->_compiled_type_constraint } map { $_->type_constraint } @attrs; my @res; my $has_triggers; my $strict = $metaclass->strict_constructor; if($strict){ push @res, 'my $used = 0;'; } for my $index (0 .. @attrs - 1) { my $code = ''; my $attr = $attrs[$index]; my $key = $attr->name; my $init_arg = $attr->init_arg; my $type_constraint = $attr->type_constraint; my $is_weak_ref = $attr->is_weak_ref; my $need_coercion; my $instance_slot = $method_class->_inline_slot('$instance', $key); my $attr_var = "\$attrs[$index]"; my $constraint_var; if(defined $type_constraint){ $constraint_var = "$attr_var\->{type_constraint}"; $need_coercion = ($attr->should_coerce && $type_constraint->has_coercion); } $code .= "# initialize $key\n"; my $post_process = ''; if(defined $type_constraint){ $post_process .= "\$checks[$index]->($instance_slot)\n"; $post_process .= " or $attr_var->_throw_type_constraint_error($instance_slot, $constraint_var);\n"; } # build cde for an attribute if (defined $init_arg) { my $value = "\$args->{q{$init_arg}}"; $code .= "if (exists $value) {\n"; if($need_coercion){ $value = "$constraint_var->coerce($value)"; } $code .= "$instance_slot = $value;\n"; $code .= $post_process; if ($attr->has_trigger) { $has_triggers++; $code .= "push \@triggers, [$attr_var\->{trigger}, $instance_slot];\n"; } if ($strict){ $code .= '++$used;' . "\n"; } $code .= "\n} else {\n"; # $value exists } if ($attr->has_default || $attr->has_builder) { unless ($attr->is_lazy) { my $default = $attr->default; my $builder = $attr->builder; my $value; if (defined($builder)) { $value = "\$instance->$builder()"; } elsif (ref($default) eq 'CODE') { $value = "$attr_var\->{default}->(\$instance)"; } elsif (defined($default)) { $value = "$attr_var\->{default}"; } else { $value = 'undef'; } if($need_coercion){ $value = "$constraint_var->coerce($value)"; } $code .= "$instance_slot = $value;\n"; $code .= $post_process; } } elsif ($attr->is_required) { $code .= "\$meta->throw_error('Attribute ($key) is required')"; $code .= " unless \$is_cloning;\n"; } $code .= "}\n" if defined $init_arg; if($is_weak_ref){ $code .= "Scalar::Util::weaken($instance_slot) " . "if ref $instance_slot and not Scalar::Util::isweak($instance_slot);\n"; } push @res, $code; } if($strict){ push @res, q{if($used < keys %{$args})} . q{{ $meta->_report_unknown_args(\@attrs, $args) }}; } if($metaclass->is_anon_class){ push @res, q{$instance->{__METACLASS__} = $meta;}; } if($has_triggers){ unshift @res, q{my @triggers;}; push @res, q{$_->[0]->($instance, $_->[1]) for @triggers;}; } my $source = sprintf <<'EOT', __FILE__, $metaclass->name, join "\n", @res; #line 1 "%s" package %s; sub { my($meta, $instance, $args, $is_cloning) = @_; %s; return $instance; } EOT warn $source if _MOUSE_DEBUG; my $body; my $e = do { local $@; $body = eval $source; $@; }; die $e if $e; return $body; } sub _generate_BUILDARGS { my(undef, $metaclass) = @_; my $class = $metaclass->name; if ( $class->can('BUILDARGS') && $class->can('BUILDARGS') != \&Mouse::Object::BUILDARGS ) { return 'my $args = $class->BUILDARGS(@_)'; } return <<'...'; my $args; if ( scalar @_ == 1 ) { ( ref( $_[0] ) eq 'HASH' ) || Carp::confess "Single parameters to new() must be a HASH ref"; $args = +{ %{ $_[0] } }; } else { $args = +{@_}; } ... } sub _generate_BUILDALL { my (undef, $metaclass) = @_; return '' unless $metaclass->name->can('BUILD'); my @code; for my $class ($metaclass->linearized_isa) { if (Mouse::Util::get_code_ref($class, 'BUILD')) { unshift @code, qq{${class}::BUILD(\$instance, \$args);}; } } return join "\n", @code; } 1; __END__ =head1 NAME Mouse::Meta::Method::Constructor - A Mouse method generator for constructors =head1 VERSION This document describes Mouse version 2.1.0 =head1 SEE ALSO L =cut Delegation.pm000644000765000024 413312245117717 20317 0ustar00gfxstaff000000000000Mouse-2.1.0/lib/Mouse/Meta/Methodpackage Mouse::Meta::Method::Delegation; use Mouse::Util qw(:meta); # enables strict and warnings use Scalar::Util; sub _generate_delegation{ my (undef, $attr, $handle_name, $method_to_call) = @_; my @curried_args; if(ref($method_to_call) eq 'ARRAY'){ ($method_to_call, @curried_args) = @{$method_to_call}; } # If it has a reader, we must use it to make method modifiers work my $reader = $attr->get_read_method() || $attr->get_read_method_ref(); my $can_be_optimized = $attr->{_mouse_cache_method_delegation_can_be_optimized}; if(!defined $can_be_optimized){ my $tc = $attr->type_constraint; $attr->{_mouse_cache_method_delegation_can_be_optimized} = (defined($tc) && $tc->is_a_type_of('Object')) && ($attr->is_required || $attr->has_default || $attr->has_builder) && ($attr->is_lazy || !$attr->has_clearer); } if($can_be_optimized){ # need not check the attribute value return sub { return shift()->$reader()->$method_to_call(@curried_args, @_); }; } else { # need to check the attribute value return sub { my $instance = shift; my $proxy = $instance->$reader(); my $error = !defined($proxy) ? ' is not defined' : ref($proxy) && !Scalar::Util::blessed($proxy) ? qq{ is not an object (got '$proxy')} : undef; if ($error) { $instance->meta->throw_error( "Cannot delegate $handle_name to $method_to_call because " . "the value of " . $attr->name . $error ); } $proxy->$method_to_call(@curried_args, @_); }; } } 1; __END__ =head1 NAME Mouse::Meta::Method::Delegation - A Mouse method generator for delegation methods =head1 VERSION This document describes Mouse version 2.1.0 =head1 SEE ALSO L =cut Destructor.pm000644000765000024 276312245117717 20411 0ustar00gfxstaff000000000000Mouse-2.1.0/lib/Mouse/Meta/Methodpackage Mouse::Meta::Method::Destructor; use Mouse::Util qw(:meta); # enables strict and warnings use constant _MOUSE_DEBUG => $ENV{MOUSE_DEBUG} ? 1 : 0; sub _generate_destructor{ my (undef, $metaclass) = @_; my $demolishall = ''; for my $class ($metaclass->linearized_isa) { if (Mouse::Util::get_code_ref($class, 'DEMOLISH')) { $demolishall .= ' ' . $class . '::DEMOLISH($self, Mouse::Util::in_global_destruction());' . "\n", } } if($demolishall) { $demolishall = sprintf <<'EOT', $demolishall; my $e = do{ local $?; local $@; eval{ %s; }; $@; }; no warnings 'misc'; die $e if $e; # rethrow EOT } my $name = $metaclass->name; my $source = sprintf(<<'EOT', __FILE__, $name, $demolishall); #line 1 "%s" package %s; sub { my($self) = @_; return $self->Mouse::Object::DESTROY() if ref($self) ne __PACKAGE__; # DEMOLISHALL %s; return; } EOT warn $source if _MOUSE_DEBUG; my $code; my $e = do{ local $@; $code = eval $source; $@; }; die $e if $e; return $code; } 1; __END__ =head1 NAME Mouse::Meta::Method::Destructor - A Mouse method generator for destructors =head1 VERSION This document describes Mouse version 2.1.0 =head1 SEE ALSO L =cut Module.pm000644000765000024 2242212245117717 16272 0ustar00gfxstaff000000000000Mouse-2.1.0/lib/Mouse/Metapackage Mouse::Meta::Module; use Mouse::Util qw/:meta/; # enables strict and warnings use Carp (); use Scalar::Util (); my %METAS; if(Mouse::Util::MOUSE_XS){ # register meta storage for performance Mouse::Util::__register_metaclass_storage(\%METAS, 0); # ensure thread safety *CLONE = sub { Mouse::Util::__register_metaclass_storage(\%METAS, 1) }; } sub initialize { my($class, $package_name, @args) = @_; ($package_name && !ref($package_name)) || $class->throw_error("You must pass a package name and it cannot be blessed"); return $METAS{$package_name} ||= $class->_construct_meta(package => $package_name, @args); } sub reinitialize { my($class, $package_name, @args) = @_; $package_name = $package_name->name if ref $package_name; ($package_name && !ref($package_name)) || $class->throw_error("You must pass a package name and it cannot be blessed"); if(exists $METAS{$package_name}) { unshift @args, %{ $METAS{$package_name} }; } delete $METAS{$package_name}; return $class->initialize($package_name, @args); } sub _class_of{ my($class_or_instance) = @_; return undef unless defined $class_or_instance; return $METAS{ ref($class_or_instance) || $class_or_instance }; } # Means of accessing all the metaclasses that have # been initialized thus far. # The public versions are aliased into Mouse::Util::*. #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 _does_metaclass_exist { defined $METAS{$_[0]} } #sub _remove_metaclass_by_name { delete $METAS{$_[0]} } sub name; sub namespace; # add_attribute is an abstract method sub get_attribute_map { # DEPRECATED Carp::cluck('get_attribute_map() has been deprecated. Use get_attribute_list() and get_attribute() instead'); return $_[0]->{attributes}; } sub has_attribute { exists $_[0]->{attributes}->{$_[1]} } sub get_attribute { $_[0]->{attributes}->{$_[1]} } sub remove_attribute { delete $_[0]->{attributes}->{$_[1]} } sub get_attribute_list{ keys %{$_[0]->{attributes}} } # XXX: not completely compatible with Moose my %foreign = map{ $_ => undef } qw( Mouse Mouse::Role Mouse::Util Mouse::Util::TypeConstraints Carp Scalar::Util List::Util ); sub _get_method_body { my($self, $method_name) = @_; my $code = Mouse::Util::get_code_ref($self->{package}, $method_name); return $code && !exists $foreign{ Mouse::Util::get_code_package($code) } ? $code : undef; } sub add_method; sub has_method { my($self, $method_name) = @_; defined($method_name) or $self->throw_error('You must define a method name'); return defined( $self->{methods}{$method_name} ) || defined( $self->_get_method_body($method_name) ); } sub get_method_body { my($self, $method_name) = @_; defined($method_name) or $self->throw_error('You must define a method name'); return $self->{methods}{$method_name} ||= $self->_get_method_body($method_name); } sub get_method { my($self, $method_name) = @_; if(my $code = $self->get_method_body($method_name)){ return Mouse::Util::load_class($self->method_metaclass)->wrap( body => $code, name => $method_name, package => $self->name, associated_metaclass => $self, ); } return undef; } sub get_method_list { my($self) = @_; return grep { $self->has_method($_) } keys %{ $self->namespace }; } sub _collect_methods { # Mouse specific, used for method modifiers my($meta, @args) = @_; my @methods; foreach my $arg(@args){ if(my $type = ref $arg){ if($type eq 'Regexp'){ push @methods, grep { $_ =~ $arg } $meta->get_all_method_names; } elsif($type eq 'ARRAY'){ push @methods, @{$arg}; } else{ my $subname = ( caller(1) )[3]; $meta->throw_error( sprintf( 'Methods passed to %s must be provided as a list,' . ' ArrayRef or regular expression, not %s', $subname, $type, ) ); } } else{ push @methods, $arg; } } return @methods; } my $ANON_SERIAL = 0; # anonymous class/role id my %IMMORTALS; # immortal anonymous classes sub create { my($self, $package_name, %options) = @_; my $class = ref($self) || $self; $self->throw_error('You must pass a package name') if @_ < 2; my $superclasses; if(exists $options{superclasses}){ if(Mouse::Util::is_a_metarole($self)){ delete $options{superclasses}; } else{ $superclasses = delete $options{superclasses}; (ref $superclasses eq 'ARRAY') || $self->throw_error("You must pass an ARRAY ref of superclasses"); } } my $attributes = delete $options{attributes}; if(defined $attributes){ (ref $attributes eq 'ARRAY' || ref $attributes eq 'HASH') || $self->throw_error("You must pass an ARRAY ref of attributes"); } my $methods = delete $options{methods}; if(defined $methods){ (ref $methods eq 'HASH') || $self->throw_error("You must pass a HASH ref of methods"); } my $roles = delete $options{roles}; if(defined $roles){ (ref $roles eq 'ARRAY') || $self->throw_error("You must pass an ARRAY ref of roles"); } my $mortal; my $cache_key; if(!defined $package_name){ # anonymous $mortal = !$options{cache}; # anonymous but immortal if(!$mortal){ # something like Super::Class|Super::Class::2=Role|Role::1 $cache_key = join '=' => ( join('|', @{$superclasses || []}), join('|', sort @{$roles || []}), ); return $IMMORTALS{$cache_key} if exists $IMMORTALS{$cache_key}; } $options{anon_serial_id} = ++$ANON_SERIAL; $package_name = $class . '::__ANON__::' . $ANON_SERIAL; } # instantiate a module { no strict 'refs'; ${ $package_name . '::VERSION' } = delete $options{version} if exists $options{version}; ${ $package_name . '::AUTHORITY' } = delete $options{authority} if exists $options{authority}; } my $meta = $self->initialize( $package_name, %options); Scalar::Util::weaken($METAS{$package_name}) if $mortal; $meta->add_method(meta => sub { $self->initialize(ref($_[0]) || $_[0]); }); $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) { if(ref($attributes) eq 'ARRAY'){ # array of Mouse::Meta::Attribute foreach my $attr (@{$attributes}) { $meta->add_attribute($attr); } } else{ # hash map of name and attribute spec pairs while(my($name, $attr) = each %{$attributes}){ $meta->add_attribute($name => $attr); } } } if (defined $methods) { while(my($method_name, $method_body) = each %{$methods}){ $meta->add_method($method_name, $method_body); } } if (defined $roles and !$options{in_application_to_instance}){ Mouse::Util::apply_all_roles($package_name, @{$roles}); } if($cache_key){ $IMMORTALS{$cache_key} = $meta; } return $meta; } sub DESTROY{ my($self) = @_; return if Mouse::Util::in_global_destruction(); my $serial_id = $self->{anon_serial_id}; return if !$serial_id; # XXX: cleaning stash with threads causes panic/SEGV on legacy perls. if(exists $INC{'threads.pm'}) { # (caller)[2] indicates the caller's line number, # which is zero when the current thread is joining (destroying). return if( (caller)[2] == 0); } # clean up mortal anonymous class stuff # @ISA is a magical variable, so we must clear it manually. @{$self->{superclasses}} = () if exists $self->{superclasses}; # Then, clear the symbol table hash %{$self->namespace} = (); my $name = $self->name; delete $METAS{$name}; $name =~ s/ $serial_id \z//xms; no strict 'refs'; delete ${$name}{ $serial_id . '::' }; return; } 1; __END__ =head1 NAME Mouse::Meta::Module - The common base class of Mouse::Meta::Class and Mouse::Meta::Role =head1 VERSION This document describes Mouse version 2.1.0 =head1 DESCRIPTION This class is an abstract base class of meta classes and meta roles. =head1 SEE ALSO L L L =cut Role.pm000644000765000024 654612245117717 15737 0ustar00gfxstaff000000000000Mouse-2.1.0/lib/Mouse/Metapackage Mouse::Meta::Role; use Mouse::Util qw(:meta); # enables strict and warnings use Mouse::Meta::Module; our @ISA = qw(Mouse::Meta::Module); sub method_metaclass; sub _construct_meta { my $class = shift; my %args = @_; $args{methods} = {}; $args{attributes} = {}; $args{required_methods} = []; $args{roles} = []; my $self = bless \%args, ref($class) || $class; if($class ne __PACKAGE__){ $self->meta->_initialize_object($self, \%args); } return $self; } sub create_anon_role{ my $self = shift; return $self->create(undef, @_); } sub is_anon_role; sub get_roles; sub calculate_all_roles { my $self = shift; my %seen; return grep { !$seen{ $_->name }++ } ($self, map { $_->calculate_all_roles } @{ $self->get_roles }); } sub get_required_method_list{ return @{ $_[0]->{required_methods} }; } sub add_required_methods { my($self, @methods) = @_; my %required = map{ $_ => 1 } @{$self->{required_methods}}; push @{$self->{required_methods}}, grep{ !$required{$_}++ && !$self->has_method($_) } @methods; return; } sub requires_method { my($self, $name) = @_; return scalar( grep{ $_ eq $name } @{ $self->{required_methods} } ) != 0; } sub add_attribute { my $self = shift; my $name = shift; $self->{attributes}->{$name} = (@_ == 1) ? $_[0] : { @_ }; return; } sub apply { my $self = shift; my $consumer = shift; require 'Mouse/Meta/Role/Application.pm'; return Mouse::Meta::Role::Application->new(@_)->apply($self, $consumer); } sub combine { my($self, @role_specs) = @_; require 'Mouse/Meta/Role/Composite.pm'; return Mouse::Meta::Role::Composite->new(roles => \@role_specs); } sub add_before_method_modifier; sub add_around_method_modifier; sub add_after_method_modifier; sub get_before_method_modifiers; sub get_around_method_modifiers; sub get_after_method_modifiers; sub add_override_method_modifier{ my($self, $method_name, $method) = @_; if($self->has_method($method_name)){ # This error happens in the override keyword or during role composition, # so I added a message, "A local method of ...", only for compatibility (gfx) $self->throw_error("Cannot add an override of method '$method_name' " . "because there is a local version of '$method_name'" . "(A local method of the same name as been found)"); } $self->{override_method_modifiers}->{$method_name} = $method; } sub get_override_method_modifier { my ($self, $method_name) = @_; return $self->{override_method_modifiers}->{$method_name}; } sub does_role { my ($self, $role_name) = @_; (defined $role_name) || $self->throw_error("You must supply a role name to look for"); $role_name = $role_name->name if ref $role_name; # if we are it,.. then return true return 1 if $role_name eq $self->name; # otherwise.. check our children for my $role (@{ $self->get_roles }) { return 1 if $role->does_role($role_name); } return 0; } 1; __END__ =head1 NAME Mouse::Meta::Role - The Mouse Role metaclass =head1 VERSION This document describes Mouse version 2.1.0 =head1 DESCRIPTION This class is a meta object protocol for Mouse roles, which is a subset of Moose::Meta:::Role. =head1 SEE ALSO L =cut Application.pm000644000765000024 1465012245117717 20215 0ustar00gfxstaff000000000000Mouse-2.1.0/lib/Mouse/Meta/Rolepackage Mouse::Meta::Role::Application; use Mouse::Util qw(:meta); sub new { my $class = shift; my $args = $class->Mouse::Object::BUILDARGS(@_); if(exists $args->{exclude} or exists $args->{alias}) { warnings::warnif(deprecated => 'The alias and excludes options for role application have been' . ' renamed -alias and -exclude'); if($args->{alias} && !exists $args->{-alias}){ $args->{-alias} = $args->{alias}; } if($args->{excludes} && !exists $args->{-excludes}){ $args->{-excludes} = $args->{excludes}; } } $args->{aliased_methods} = {}; if(my $alias = $args->{-alias}){ @{$args->{aliased_methods}}{ values %{$alias} } = (); } if(my $excludes = $args->{-excludes}){ $args->{-excludes} = {}; # replace with a hash ref if(ref $excludes){ %{$args->{-excludes}} = (map{ $_ => undef } @{$excludes}); } else{ $args->{-excludes}{$excludes} = undef; } } my $self = bless $args, $class; if($class ne __PACKAGE__){ $self->meta->_initialize_object($self, $args); } return $self; } sub apply { my($self, $role, $consumer, @extra) = @_; my $instance; if(Mouse::Util::is_a_metaclass($consumer)) { # Application::ToClass $self->{_to} = 'class'; } elsif(Mouse::Util::is_a_metarole($consumer)) { # Application::ToRole $self->{_to} = 'role'; } else { # Appplication::ToInstance $self->{_to} = 'instance'; $instance = $consumer; $consumer = (Mouse::Util::class_of($instance) || 'Mouse::Meta::Class') ->create_anon_class( superclasses => [ref $instance], roles => [$role], cache => 1, in_application_to_instance => 1, # suppress to apply roles ); } #$self->check_role_exclusions($role, $consumer, @extra); $self->check_required_methods($role, $consumer, @extra); #$self->check_required_attributes($role, $consumer, @extra); $self->apply_attributes($role, $consumer, @extra); $self->apply_methods($role, $consumer, @extra); #$self->apply_override_method_modifiers($role, $consumer, @extra); #$self->apply_before_method_modifiers($role, $consumer, @extra); #$self->apply_around_method_modifiers($role, $consumer, @extra); #$self->apply_after_method_modifiers($role, $consumer, @extra); $self->apply_modifiers($role, $consumer, @extra); $self->_append_roles($role, $consumer); if(defined $instance){ # Application::ToInstance # rebless instance bless $instance, $consumer->name; $consumer->_initialize_object($instance, $instance, 1); } return; } sub check_required_methods { my($self, $role, $consumer) = @_; if($self->{_to} eq 'role'){ $consumer->add_required_methods($role->get_required_method_list); } else{ # to class or instance my $consumer_class_name = $consumer->name; my @missing; foreach my $method_name(@{$role->{required_methods}}){ next if exists $self->{aliased_methods}{$method_name}; next if exists $role->{methods}{$method_name}; next if $consumer_class_name->can($method_name); push @missing, $method_name; } if(@missing){ $role->throw_error(sprintf "'%s' requires the method%s %s to be implemented by '%s'", $role->name, (@missing == 1 ? '' : 's'), # method or methods Mouse::Util::quoted_english_list(@missing), $consumer_class_name); } } return; } sub apply_methods { my($self, $role, $consumer) = @_; my $alias = $self->{-alias}; my $excludes = $self->{-excludes}; foreach my $method_name($role->get_method_list){ next if $method_name eq 'meta'; my $code = $role->get_method_body($method_name); if(!exists $excludes->{$method_name}){ if(!$consumer->has_method($method_name)){ # The third argument $role is used in Role::Composite $consumer->add_method($method_name => $code, $role); } } if(exists $alias->{$method_name}){ my $dstname = $alias->{$method_name}; my $dstcode = $consumer->get_method_body($dstname); if(defined($dstcode) && $dstcode != $code){ $role->throw_error("Cannot create a method alias if a local method of the same name exists"); } else{ $consumer->add_method($dstname => $code, $role); } } } return; } sub apply_attributes { my($self, $role, $consumer) = @_; for my $attr_name ($role->get_attribute_list) { next if $consumer->has_attribute($attr_name); $consumer->add_attribute($attr_name => $role->get_attribute($attr_name)); } return; } sub apply_modifiers { my($self, $role, $consumer) = @_; if(my $modifiers = $role->{override_method_modifiers}){ foreach my $method_name (keys %{$modifiers}){ $consumer->add_override_method_modifier( $method_name => $modifiers->{$method_name}); } } for my $modifier_type (qw/before around after/) { my $table = $role->{"${modifier_type}_method_modifiers"} or next; my $add_modifier = "add_${modifier_type}_method_modifier"; while(my($method_name, $modifiers) = each %{$table}){ foreach my $code(@{ $modifiers }) { # skip if the modifier is already applied next if $consumer->{"_applied_$modifier_type"}{$method_name, $code}++; $consumer->$add_modifier($method_name => $code); } } } return; } sub _append_roles { my($self, $role, $metaclass_or_role) = @_; my $roles = $metaclass_or_role->{roles}; foreach my $r($role, @{$role->get_roles}){ if(!$metaclass_or_role->does_role($r)){ push @{$roles}, $r; } } return; } 1; __END__ =head1 NAME Mouse::Meta::Role::Application - The Mouse role application class =head1 VERSION This document describes Mouse version 2.1.0 =head1 SEE ALSO L L L L =cut Composite.pm000644000765000024 1345112245117717 17712 0ustar00gfxstaff000000000000Mouse-2.1.0/lib/Mouse/Meta/Rolepackage Mouse::Meta::Role::Composite; use Carp (); use Mouse::Util; # enables strict and warnings use Mouse::Meta::Role; use Mouse::Meta::Role::Application; our @ISA = qw(Mouse::Meta::Role); # FIXME: Mouse::Meta::Role::Composite does things in different way from Moose's # Moose: creates a new class for the consumer, and applies roles to it. # Mouse: creates a composite role and apply roles to the role, # and then applies it to the consumer. sub new { my $class = shift; my $args = $class->Mouse::Object::BUILDARGS(@_); my $roles = delete $args->{roles}; my $self = $class->create_anon_role(%{$args}); foreach my $role_spec(@{$roles}) { my($role, $args) = ref($role_spec) eq 'ARRAY' ? @{$role_spec} : ($role_spec, {}); $role->apply($self, %{$args}); } return $self; } sub get_method_list { my($self) = @_; return grep { ! $self->{conflicting_methods}{$_} } keys %{ $self->{methods} }; } sub add_method { my($self, $method_name, $code, $role) = @_; if( ($self->{methods}{$method_name} || 0) == $code){ # This role already has the same method. return; } if($method_name eq 'meta'){ $self->SUPER::add_method($method_name => $code); } else{ # no need to add a subroutine to the stash my $roles = $self->{composed_roles_by_method}{$method_name} ||= []; push @{$roles}, $role; if(@{$roles} > 1){ $self->{conflicting_methods}{$method_name}++; } $self->{methods}{$method_name} = $code; } return; } sub get_method_body { my($self, $method_name) = @_; return $self->{methods}{$method_name}; } sub has_method { # my($self, $method_name) = @_; return 0; # to fool apply_methods() in combine() } sub has_attribute { # my($self, $method_name) = @_; return 0; # to fool appply_attributes() in combine() } sub has_override_method_modifier { # my($self, $method_name) = @_; return 0; # to fool apply_modifiers() in combine() } sub add_attribute { my $self = shift; my $attr_name = shift; my $spec = (@_ == 1 ? $_[0] : {@_}); my $existing = $self->{attributes}{$attr_name}; if($existing && $existing != $spec){ $self->throw_error("We have encountered an attribute conflict with '$attr_name' " . "during composition. This is fatal error and cannot be disambiguated."); } $self->SUPER::add_attribute($attr_name, $spec); return; } sub add_override_method_modifier { my($self, $method_name, $code) = @_; my $existing = $self->{override_method_modifiers}{$method_name}; if($existing && $existing != $code){ $self->throw_error( "We have encountered an 'override' method conflict with '$method_name' during " . "composition (Two 'override' methods of the same name encountered). " . "This is fatal error.") } $self->SUPER::add_override_method_modifier($method_name, $code); return; } sub apply { my $self = shift; my $consumer = shift; Mouse::Meta::Role::Application::RoleSummation->new(@_)->apply($self, $consumer); return; } package Mouse::Meta::Role::Application::RoleSummation; our @ISA = qw(Mouse::Meta::Role::Application); sub apply_methods { my($self, $role, $consumer, @extra) = @_; if(exists $role->{conflicting_methods}){ my $consumer_class_name = $consumer->name; my @conflicting = grep{ !$consumer_class_name->can($_) } keys %{ $role->{conflicting_methods} }; if(@conflicting) { my $method_name_conflict = (@conflicting == 1 ? 'a method name conflict' : 'method name conflicts'); my %seen; my $roles = Mouse::Util::quoted_english_list( grep{ !$seen{$_}++ } # uniq map { $_->name } map { @{$_} } @{ $role->{composed_roles_by_method} }{@conflicting} ); $self->throw_error(sprintf q{Due to %s in roles %s,} . q{ the method%s %s must be implemented or excluded by '%s'}, $method_name_conflict, $roles, (@conflicting > 1 ? 's' : ''), Mouse::Util::quoted_english_list(@conflicting), $consumer_class_name); } my @changed_in_v2_0_0 = grep { $consumer_class_name->can($_) && ! $consumer->has_method($_) } keys %{ $role->{conflicting_methods} }; if (@changed_in_v2_0_0) { my $method_name_conflict = (@changed_in_v2_0_0 == 1 ? 'a method name conflict' : 'method name conflicts'); my %seen; my $roles = Mouse::Util::quoted_english_list( grep{ !$seen{$_}++ } # uniq map { $_->name } map { @{$_} } @{ $role->{composed_roles_by_method} }{@changed_in_v2_0_0} ); Carp::cluck(sprintf q{Due to %s in roles %s,} . q{ the behavior of method%s %s might be changed} . q{ in Mouse-2.00, check it out}, $method_name_conflict, $roles, (@changed_in_v2_0_0 > 1 ? 's' : ''), Mouse::Util::quoted_english_list(@changed_in_v2_0_0), $consumer_class_name); } } $self->SUPER::apply_methods($role, $consumer, @extra); return; } package Mouse::Meta::Role::Composite; 1; __END__ =head1 NAME Mouse::Meta::Role::Composite - An object to represent the set of roles =head1 VERSION This document describes Mouse version 2.1.0 =head1 SEE ALSO L =cut Method.pm000644000765000024 103212245117717 17140 0ustar00gfxstaff000000000000Mouse-2.1.0/lib/Mouse/Meta/Rolepackage Mouse::Meta::Role::Method; use Mouse::Util; # enables strict and warnings use Mouse::Meta::Method; our @ISA = qw(Mouse::Meta::Method); sub _new{ my($class, %args) = @_; my $self = bless \%args, $class; if($class ne __PACKAGE__){ $self->meta->_initialize_object($self, \%args); } return $self; } 1; __END__ =head1 NAME Mouse::Meta::Role::Method - A Mouse Method metaclass for Roles =head1 VERSION This document describes Mouse version 2.1.0 =head1 SEE ALSO L =cut TypeConstraint.pm000644000765000024 2034612245117717 20036 0ustar00gfxstaff000000000000Mouse-2.1.0/lib/Mouse/Metapackage Mouse::Meta::TypeConstraint; use Mouse::Util qw(:meta); # enables strict and warnings sub new { my $class = shift; my %args = @_ == 1 ? %{$_[0]} : @_; $args{name} = '__ANON__' if !defined $args{name}; my $type_parameter; if(defined $args{parent}) { # subtyping %args = (%{$args{parent}}, %args); # a child type must not inherit 'compiled_type_constraint' # and 'hand_optimized_type_constraint' from the parent delete $args{compiled_type_constraint}; # don't inherit it delete $args{hand_optimized_type_constraint}; # don't inherit it $type_parameter = $args{type_parameter}; if(defined(my $parent_tp = $args{parent}{type_parameter})) { if($parent_tp != $type_parameter) { $type_parameter->is_a_type_of($parent_tp) or $class->throw_error( "$type_parameter is not a subtype of $parent_tp", ); } else { $type_parameter = undef; } } } my $check; if($check = delete $args{optimized}) { # likely to be builtins $args{hand_optimized_type_constraint} = $check; $args{compiled_type_constraint} = $check; } elsif(defined $type_parameter) { # parameterizing my $generator = $args{constraint_generator} || $class->throw_error( "The $args{name} constraint cannot be used," . " because $type_parameter doesn't subtype" . " from a parameterizable type"); my $parameterized_check = $generator->($type_parameter); if(defined(my $my_check = $args{constraint})) { $check = sub { return $parameterized_check->($_) && $my_check->($_); }; } else { $check = $parameterized_check; } $args{constraint} = $check; } else { # common cases $check = $args{constraint}; } if(defined($check) && ref($check) ne 'CODE'){ $class->throw_error( "Constraint for $args{name} is not a CODE reference"); } my $self = bless \%args, $class; $self->compile_type_constraint() if !$args{hand_optimized_type_constraint}; if($args{type_constraints}) { # union types foreach my $type(@{$self->{type_constraints}}){ if($type->has_coercion){ # set undef for has_coercion() $self->{_compiled_type_coercion} = undef; last; } } } return $self; } sub create_child_type { my $self = shift; return ref($self)->new(@_, parent => $self); } sub name; sub parent; sub message; sub has_coercion; sub check; sub type_parameter; sub __is_parameterized; sub _compiled_type_constraint; sub _compiled_type_coercion; sub compile_type_constraint; sub _add_type_coercions { # ($self, @pairs) my $self = shift; if(exists $self->{type_constraints}){ # union type $self->throw_error( "Cannot add additional type coercions to Union types '$self'"); } my $coercion_map = ($self->{coercion_map} ||= []); my %has = map{ $_->[0]->name => undef } @{$coercion_map}; for(my $i = 0; $i < @_; $i++){ my $from = $_[ $i]; my $action = $_[++$i]; if(exists $has{$from}){ $self->throw_error("A coercion action already exists for '$from'"); } my $type = Mouse::Util::TypeConstraints::find_or_parse_type_constraint($from) or $self->throw_error( "Could not find the type constraint ($from) to coerce from"); push @{$coercion_map}, [ $type => $action ]; } $self->{_compiled_type_coercion} = undef; return; } sub _compiled_type_coercion { my($self) = @_; my $coercion = $self->{_compiled_type_coercion}; return $coercion if defined $coercion; if(!$self->{type_constraints}) { my @coercions; foreach my $pair(@{$self->{coercion_map}}) { push @coercions, [ $pair->[0]->_compiled_type_constraint, $pair->[1] ]; } $coercion = sub { my($thing) = @_; foreach my $pair (@coercions) { #my ($constraint, $converter) = @$pair; if ($pair->[0]->($thing)) { return $pair->[1]->($thing) for $thing; # local $_ will cancel tie-ness due to perl's bug } } return $thing; }; } else { # for union type my @coercions; foreach my $type(@{$self->{type_constraints}}){ if($type->has_coercion){ push @coercions, $type; } } if(@coercions){ $coercion = sub { my($thing) = @_; foreach my $type(@coercions){ my $value = $type->coerce($thing); return $value if $self->check($value); } return $thing; }; } } return( $self->{_compiled_type_coercion} = $coercion ); } sub coerce { my $self = shift; return $_[0] if $self->check(@_); my $coercion = $self->_compiled_type_coercion or $self->throw_error("Cannot coerce without a type coercion"); return $coercion->(@_); } sub get_message { my ($self, $value) = @_; if ( my $msg = $self->message ) { return $msg->($value) for $value; # local $_ will cancel tie-ness due to perl's bug } else { if(not defined $value) { $value = 'undef'; } elsif( ref($value) && defined(&overload::StrVal) ) { $value = overload::StrVal($value); } return "Validation failed for '$self' with value $value"; } } sub is_a_type_of { my($self, $other) = @_; # ->is_a_type_of('__ANON__') is always false return 0 if !ref($other) && $other eq '__ANON__'; (my $other_name = $other) =~ s/\s+//g; return 1 if $self->name eq $other_name; if(exists $self->{type_constraints}){ # union foreach my $type(@{$self->{type_constraints}}) { return 1 if $type->name eq $other_name; } } for(my $p = $self->parent; defined $p; $p = $p->parent) { return 1 if $p->name eq $other_name; } return 0; } # See also Moose::Meta::TypeConstraint::Parameterizable sub parameterize { my($self, $param, $name) = @_; if(!ref $param){ require Mouse::Util::TypeConstraints; $param = Mouse::Util::TypeConstraints::find_or_create_isa_type_constraint($param); } $name ||= sprintf '%s[%s]', $self->name, $param->name; return Mouse::Meta::TypeConstraint->new( name => $name, parent => $self, type_parameter => $param, ); } sub assert_valid { my ($self, $value) = @_; if(!$self->check($value)){ $self->throw_error($self->get_message($value)); } return 1; } # overloading stuff sub _as_string { $_[0]->name } # overload "" sub _identity; # overload 0+ sub _unite { # overload infix:<|> my($lhs, $rhs) = @_; require Mouse::Util::TypeConstraints; return Mouse::Util::TypeConstraints::_find_or_create_union_type( $lhs, Mouse::Util::TypeConstraints::find_or_create_isa_type_constraint($rhs), ); } 1; __END__ =head1 NAME Mouse::Meta::TypeConstraint - The Mouse Type Constraint metaclass =head1 VERSION This document describes Mouse version 2.1.0 =head1 DESCRIPTION This class represents a type constraint, including built-in type constraints, union type constraints, parameterizable/ parameterized type constraints, as well as custom type constraints =head1 METHODS =over =item C<< Mouse::Meta::TypeConstraint->new(%options) >> =item C<< $constraint->name >> =item C<< $constraint->parent >> =item C<< $constraint->constraint >> =item C<< $constraint->has_coercion >> =item C<< $constraint->message >> =item C<< $constraint->is_a_type_of($name or $object) >> =item C<< $constraint->coerce($value) >> =item C<< $constraint->check($value) >> =item C<< $constraint->assert_valid($value) >> =item C<< $constraint->get_message($value) >> =item C<< $constraint->create_child_type(%options) >> =back =head1 SEE ALSO L =cut Object.pm000644000765000024 340412245117717 15344 0ustar00gfxstaff000000000000Mouse-2.1.0/lib/Mousepackage Mouse::Object; use Mouse::Util qw(does dump meta); # enables strict and warnings # all the stuff are defined in XS or PP sub DOES { my($self, $class_or_role_name) = @_; return $self->isa($class_or_role_name) || $self->does($class_or_role_name); } 1; __END__ =head1 NAME Mouse::Object - The base object for Mouse classes =head1 VERSION This document describes Mouse version 2.1.0 =head1 METHODS =head2 C<< $class->new(%args | \%args) -> Object >> Instantiates a new C. This is obviously intended for subclasses. =head2 C<< $class->BUILDARGS(@args) -> HashRef >> Lets you override the arguments that C takes. It must return a HashRef of parameters. =head2 C<< $object->BUILDALL(\%args) >> Calls C on each class in the class hierarchy. This is called at the end of C. =head2 C<< $object->BUILD(\%args) >> You may put any business logic initialization in BUILD methods. You don't need to redispatch or return any specific value. =head2 C<< $object->DEMOLISHALL >> Calls C on each class in the class hierarchy. This is called at C time. =head2 C<< $object->DEMOLISH >> You may put any business logic deinitialization in DEMOLISH methods. You don't need to redispatch or return any specific value. =head2 C<< $object->does($role_name) -> Bool >> This will check if the invocant's class B a given C<$role_name>. This is similar to C for object, but it checks the roles instead. =head2 C<< $object->dump($maxdepth) -> Str >> This is a handy utility for dumping an object with Data::Dumper. By default, the maximum depth is 3, to avoid making a mess. =head2 C<< $object->meta() -> MetaClass >> This is a method which provides access to the object's metaclass. =head1 SEE ALSO L =cut PurePerl.pm000644000765000024 5101712245117717 15717 0ustar00gfxstaff000000000000Mouse-2.1.0/lib/Mousepackage Mouse::PurePerl; # The pure Perl backend for Mouse package Mouse::Util; use strict; use warnings; use warnings FATAL => 'redefine'; # to avoid to load Mouse::PurePerl twice use Scalar::Util (); use B (); require Mouse::Util; # taken from Class/MOP.pm sub is_valid_class_name { my $class = shift; return 0 if ref($class); return 0 unless defined($class); return 1 if $class =~ /\A \w+ (?: :: \w+ )* \z/xms; return 0; } sub is_class_loaded { my $class = shift; return 0 if ref($class) || !defined($class) || !length($class); # walk the symbol table tree to avoid autovififying # \*{${main::}{"Foo::"}{"Bar::"}} == \*main::Foo::Bar:: my $pack = \%::; foreach my $part (split('::', $class)) { $part .= '::'; return 0 if !exists $pack->{$part}; my $entry = \$pack->{$part}; return 0 if ref($entry) ne 'GLOB'; $pack = *{$entry}{HASH}; } return 0 if !%{$pack}; # check for $VERSION or @ISA return 1 if exists $pack->{VERSION} && defined *{$pack->{VERSION}}{SCALAR} && defined ${ $pack->{VERSION} }; return 1 if exists $pack->{ISA} && defined *{$pack->{ISA}}{ARRAY} && @{ $pack->{ISA} } != 0; # check for any method foreach my $name( keys %{$pack} ) { my $entry = \$pack->{$name}; return 1 if ref($entry) ne 'GLOB' || defined *{$entry}{CODE}; } # fail return 0; } # taken from Sub::Identify sub get_code_info { my ($coderef) = @_; ref($coderef) or return; my $cv = B::svref_2object($coderef); $cv->isa('B::CV') or return; my $gv = $cv->GV; $gv->isa('B::GV') or return; return ($gv->STASH->NAME, $gv->NAME); } sub get_code_package{ my($coderef) = @_; my $cv = B::svref_2object($coderef); $cv->isa('B::CV') or return ''; my $gv = $cv->GV; $gv->isa('B::GV') or return ''; return $gv->STASH->NAME; } sub get_code_ref{ my($package, $name) = @_; no strict 'refs'; no warnings 'once'; use warnings FATAL => 'uninitialized'; return *{$package . '::' . $name}{CODE}; } sub generate_isa_predicate_for { my($for_class, $name) = @_; my $predicate = sub{ Scalar::Util::blessed($_[0]) && $_[0]->isa($for_class) }; if(defined $name){ Mouse::Util::install_subroutines(scalar caller, $name => $predicate); return; } return $predicate; } sub generate_can_predicate_for { my($methods_ref, $name) = @_; my @methods = @{$methods_ref}; my $predicate = sub{ my($instance) = @_; if(Scalar::Util::blessed($instance)){ foreach my $method(@methods){ if(!$instance->can($method)){ return 0; } } return 1; } return 0; }; if(defined $name){ Mouse::Util::install_subroutines(scalar caller, $name => $predicate); return; } return $predicate; } package Mouse::Util::TypeConstraints; sub Any { 1 } sub Item { 1 } sub Bool { !$_[0] || $_[0] eq '1' } sub Undef { !defined($_[0]) } sub Defined { defined($_[0]) } sub Value { defined($_[0]) && !ref($_[0]) } sub Num { Scalar::Util::looks_like_number($_[0]) } sub Str { # We need to use a copy here to flatten MAGICs, for instance as in # Str( substr($_, 0, 42) ). my($value) = @_; return defined($value) && ref(\$value) eq 'SCALAR'; } sub Int { # We need to use a copy here to save the original internal SV flags. my($value) = @_; return defined($value) && $value =~ /\A -? [0-9]+ \z/xms; } sub Ref { ref($_[0]) } sub ScalarRef { my($value) = @_; return ref($value) eq 'SCALAR' || ref($value) eq 'REF'; } sub ArrayRef { ref($_[0]) eq 'ARRAY' } sub HashRef { ref($_[0]) eq 'HASH' } sub CodeRef { ref($_[0]) eq 'CODE' } sub RegexpRef { ref($_[0]) eq 'Regexp' } sub GlobRef { ref($_[0]) eq 'GLOB' } sub FileHandle { my($value) = @_; return Scalar::Util::openhandle($value) || (Scalar::Util::blessed($value) && $value->isa("IO::Handle")) } sub Object { Scalar::Util::blessed($_[0]) && ref($_[0]) ne 'Regexp' } sub ClassName { Mouse::Util::is_class_loaded($_[0]) } sub RoleName { (Mouse::Util::class_of($_[0]) || return 0)->isa('Mouse::Meta::Role') } sub _parameterize_ArrayRef_for { my($type_parameter) = @_; my $check = $type_parameter->_compiled_type_constraint; return sub { foreach my $value (@{$_}) { return undef unless $check->($value); } return 1; } } sub _parameterize_HashRef_for { my($type_parameter) = @_; my $check = $type_parameter->_compiled_type_constraint; return sub { foreach my $value(values %{$_}){ return undef unless $check->($value); } return 1; }; } # 'Maybe' type accepts 'Any', so it requires parameters sub _parameterize_Maybe_for { my($type_parameter) = @_; my $check = $type_parameter->_compiled_type_constraint; return sub{ return !defined($_) || $check->($_); }; } package Mouse::Meta::Module; sub name { $_[0]->{package} } sub _method_map { $_[0]->{methods} } sub _attribute_map{ $_[0]->{attributes} } sub namespace{ my $name = $_[0]->{package}; no strict 'refs'; return \%{ $name . '::' }; } sub add_method { my($self, $name, $code) = @_; if(!defined $name){ $self->throw_error('You must pass a defined name'); } if(!defined $code){ $self->throw_error('You must pass a defined code'); } if(ref($code) ne 'CODE'){ $code = \&{$code}; # coerce } $self->{methods}->{$name} = $code; # Moose stores meta object here. Mouse::Util::install_subroutines($self->name, $name => $code, ); return; } my $generate_class_accessor = sub { my($name) = @_; return sub { my $self = shift; if(@_) { return $self->{$name} = shift; } foreach my $class($self->linearized_isa) { my $meta = Mouse::Util::get_metaclass_by_name($class) or next; if(exists $meta->{$name}) { return $meta->{$name}; } } return undef; }; }; package Mouse::Meta::Class; use Mouse::Meta::Method::Constructor; use Mouse::Meta::Method::Destructor; sub method_metaclass { $_[0]->{method_metaclass} || 'Mouse::Meta::Method' } sub attribute_metaclass { $_[0]->{attribute_metaclass} || 'Mouse::Meta::Attribute' } sub constructor_class { $_[0]->{constructor_class} || 'Mouse::Meta::Method::Constructor' } sub destructor_class { $_[0]->{destructor_class} || 'Mouse::Meta::Method::Destructor' } sub is_anon_class{ return exists $_[0]->{anon_serial_id}; } sub roles { $_[0]->{roles} } sub linearized_isa { @{ Mouse::Util::get_linear_isa($_[0]->{package}) } } sub new_object { my $meta = shift; my %args = (@_ == 1 ? %{$_[0]} : @_); my $object = bless {}, $meta->name; $meta->_initialize_object($object, \%args, 0); # BUILDALL if( $object->can('BUILD') ) { for my $class (reverse $meta->linearized_isa) { my $build = Mouse::Util::get_code_ref($class, 'BUILD') || next; $object->$build(\%args); } } return $object; } sub clone_object { my $class = shift; my $object = shift; my $args = $object->Mouse::Object::BUILDARGS(@_); (Scalar::Util::blessed($object) && $object->isa($class->name)) || $class->throw_error("You must pass an instance of the metaclass (" . $class->name . "), not ($object)"); my $cloned = bless { %$object }, ref $object; $class->_initialize_object($cloned, $args, 1); return $cloned; } sub _initialize_object{ my($self, $object, $args, $is_cloning) = @_; # The initializer, which is used everywhere, must be clear # when an attribute is added. See Mouse::Meta::Class::add_attribute. my $initializer = $self->{_mouse_cache}{_initialize_object} ||= Mouse::Util::load_class($self->constructor_class) ->_generate_initialize_object($self); goto &{$initializer}; } sub get_all_attributes { my($self) = @_; return @{ $self->{_mouse_cache}{all_attributes} ||= $self->_calculate_all_attributes }; } sub is_immutable { $_[0]->{is_immutable} } sub strict_constructor; *strict_constructor = $generate_class_accessor->('strict_constructor'); sub _invalidate_metaclass_cache { my($self) = @_; delete $self->{_mouse_cache}; return; } sub _report_unknown_args { my($metaclass, $attrs, $args) = @_; my @unknowns; my %init_args; foreach my $attr(@{$attrs}){ my $init_arg = $attr->init_arg; if(defined $init_arg){ $init_args{$init_arg}++; } } while(my $key = each %{$args}){ if(!exists $init_args{$key}){ push @unknowns, $key; } } $metaclass->throw_error( sprintf "Unknown attribute passed to the constructor of %s: %s", $metaclass->name, Mouse::Util::english_list(@unknowns), ); } package Mouse::Meta::Role; sub method_metaclass{ $_[0]->{method_metaclass} || 'Mouse::Meta::Role::Method' } sub is_anon_role{ return exists $_[0]->{anon_serial_id}; } sub get_roles { $_[0]->{roles} } sub add_before_method_modifier { my ($self, $method_name, $method) = @_; push @{ $self->{before_method_modifiers}{$method_name} ||= [] }, $method; return; } sub add_around_method_modifier { my ($self, $method_name, $method) = @_; push @{ $self->{around_method_modifiers}{$method_name} ||= [] }, $method; return; } sub add_after_method_modifier { my ($self, $method_name, $method) = @_; push @{ $self->{after_method_modifiers}{$method_name} ||= [] }, $method; return; } sub get_before_method_modifiers { my ($self, $method_name) = @_; return @{ $self->{before_method_modifiers}{$method_name} ||= [] } } sub get_around_method_modifiers { my ($self, $method_name) = @_; return @{ $self->{around_method_modifiers}{$method_name} ||= [] } } sub get_after_method_modifiers { my ($self, $method_name) = @_; return @{ $self->{after_method_modifiers}{$method_name} ||= [] } } sub add_metaclass_accessor { # for meta roles (a.k.a. traits) my($meta, $name) = @_; $meta->add_method($name => $generate_class_accessor->($name)); return; } package Mouse::Meta::Attribute; require Mouse::Meta::Method::Accessor; sub accessor_metaclass{ $_[0]->{accessor_metaclass} || 'Mouse::Meta::Method::Accessor' } # readers sub name { $_[0]->{name} } sub associated_class { $_[0]->{associated_class} } sub accessor { $_[0]->{accessor} } sub reader { $_[0]->{reader} } sub writer { $_[0]->{writer} } sub predicate { $_[0]->{predicate} } sub clearer { $_[0]->{clearer} } sub handles { $_[0]->{handles} } sub _is_metadata { $_[0]->{is} } sub is_required { $_[0]->{required} } sub default { my($self, $instance) = @_; my $value = $self->{default}; $value = $value->($instance) if defined($instance) and ref($value) eq "CODE"; return $value; } sub is_lazy { $_[0]->{lazy} } sub is_lazy_build { $_[0]->{lazy_build} } sub is_weak_ref { $_[0]->{weak_ref} } sub init_arg { $_[0]->{init_arg} } sub type_constraint { $_[0]->{type_constraint} } sub trigger { $_[0]->{trigger} } sub builder { $_[0]->{builder} } sub should_auto_deref { $_[0]->{auto_deref} } sub should_coerce { $_[0]->{coerce} } sub documentation { $_[0]->{documentation} } sub insertion_order { $_[0]->{insertion_order} } # predicates sub has_accessor { exists $_[0]->{accessor} } sub has_reader { exists $_[0]->{reader} } sub has_writer { exists $_[0]->{writer} } sub has_predicate { exists $_[0]->{predicate} } sub has_clearer { exists $_[0]->{clearer} } sub has_handles { exists $_[0]->{handles} } sub has_default { exists $_[0]->{default} } sub has_type_constraint { exists $_[0]->{type_constraint} } sub has_trigger { exists $_[0]->{trigger} } sub has_builder { exists $_[0]->{builder} } sub has_documentation { exists $_[0]->{documentation} } sub _process_options{ my($class, $name, $args) = @_; # taken from Class::MOP::Attribute::new defined($name) or $class->throw_error('You must provide a name for the attribute'); if(!exists $args->{init_arg}){ $args->{init_arg} = $name; } # 'required' requires either 'init_arg', 'builder', or 'default' my $can_be_required = defined( $args->{init_arg} ); if(exists $args->{builder}){ # XXX: # Moose refuses a CODE ref builder, but Mouse doesn't for backward compatibility # This feature will be changed in a future. (gfx) $class->throw_error('builder must be a defined scalar value which is a method name') #if ref $args->{builder} || !defined $args->{builder}; if !defined $args->{builder}; $can_be_required++; } elsif(exists $args->{default}){ if(ref $args->{default} && ref($args->{default}) ne 'CODE'){ $class->throw_error("References are not allowed as default values, you must " . "wrap the default of '$name' in a CODE reference (ex: sub { [] } and not [])"); } $can_be_required++; } if( $args->{required} && !$can_be_required ) { $class->throw_error("You cannot have a required attribute ($name) without a default, builder, or an init_arg"); } # taken from Mouse::Meta::Attribute->new and ->_process_args if(exists $args->{is}){ my $is = $args->{is}; if($is eq 'ro'){ $args->{reader} ||= $name; } elsif($is eq 'rw'){ if(exists $args->{writer}){ $args->{reader} ||= $name; } else{ $args->{accessor} ||= $name; } } elsif($is eq 'bare'){ # do nothing, but don't complain (later) about missing methods } else{ $is = 'undef' if !defined $is; $class->throw_error("I do not understand this option (is => $is) on attribute ($name)"); } } my $tc; if(exists $args->{isa}){ $tc = $args->{type_constraint} = Mouse::Util::TypeConstraints::find_or_create_isa_type_constraint($args->{isa}); } if(exists $args->{does}){ if(defined $tc){ # both isa and does supplied my $does_ok = do{ local $@; eval{ "$tc"->does($args->{does}) }; }; if(!$does_ok){ $class->throw_error("Cannot have both an isa option and a does option because '$tc' does not do '$args->{does}' on attribute ($name)"); } } else { $tc = $args->{type_constraint} = Mouse::Util::TypeConstraints::find_or_create_does_type_constraint($args->{does}); } } if($args->{coerce}){ defined($tc) || $class->throw_error("You cannot have coercion without specifying a type constraint on attribute ($name)"); $args->{weak_ref} && $class->throw_error("You cannot have a weak reference to a coerced value on attribute ($name)"); } if ($args->{lazy_build}) { exists($args->{default}) && $class->throw_error("You can not use lazy_build and default for the same attribute ($name)"); $args->{lazy} = 1; $args->{builder} ||= "_build_${name}"; if ($name =~ /^_/) { $args->{clearer} ||= "_clear${name}"; $args->{predicate} ||= "_has${name}"; } else { $args->{clearer} ||= "clear_${name}"; $args->{predicate} ||= "has_${name}"; } } if ($args->{auto_deref}) { defined($tc) || $class->throw_error("You cannot auto-dereference without specifying a type constraint on attribute ($name)"); ( $tc->is_a_type_of('ArrayRef') || $tc->is_a_type_of('HashRef') ) || $class->throw_error("You cannot auto-dereference anything other than a ArrayRef or HashRef on attribute ($name)"); } if (exists $args->{trigger}) { ('CODE' eq ref $args->{trigger}) || $class->throw_error("Trigger must be a CODE ref on attribute ($name)"); } if ($args->{lazy}) { (exists $args->{default} || defined $args->{builder}) || $class->throw_error("You cannot have a lazy attribute ($name) without specifying a default value for it"); } return; } package Mouse::Meta::TypeConstraint; use overload '""' => '_as_string', '0+' => '_identity', '|' => '_unite', fallback => 1; sub name { $_[0]->{name} } sub parent { $_[0]->{parent} } sub message { $_[0]->{message} } sub _identity { Scalar::Util::refaddr($_[0]) } # overload 0+ sub type_parameter { $_[0]->{type_parameter} } sub _compiled_type_constraint{ $_[0]->{compiled_type_constraint} } sub __is_parameterized { exists $_[0]->{type_parameter} } sub has_coercion { exists $_[0]->{_compiled_type_coercion} } sub compile_type_constraint{ my($self) = @_; # add parents first my @checks; for(my $parent = $self->{parent}; defined $parent; $parent = $parent->{parent}){ if($parent->{hand_optimized_type_constraint}){ unshift @checks, $parent->{hand_optimized_type_constraint}; last; # a hand optimized constraint must include all the parents } elsif($parent->{constraint}){ unshift @checks, $parent->{constraint}; } } # then add child if($self->{constraint}){ push @checks, $self->{constraint}; } if($self->{type_constraints}){ # Union my @types = map{ $_->{compiled_type_constraint} } @{ $self->{type_constraints} }; push @checks, sub{ foreach my $c(@types){ return 1 if $c->($_[0]); } return 0; }; } if(@checks == 0){ $self->{compiled_type_constraint} = \&Mouse::Util::TypeConstraints::Any; } else{ $self->{compiled_type_constraint} = sub{ my(@args) = @_; for ($args[0]) { # local $_ will cancel tie-ness due to perl's bug foreach my $c(@checks){ return undef if !$c->(@args); } } return 1; }; } return; } sub check { my $self = shift; return $self->_compiled_type_constraint->(@_); } package Mouse::Object; sub BUILDARGS { my $class = shift; if (scalar @_ == 1) { (ref($_[0]) eq 'HASH') || $class->meta->throw_error("Single parameters to new() must be a HASH ref"); return {%{$_[0]}}; } else { return {@_}; } } sub new { my $class = shift; my $args = $class->BUILDARGS(@_); return $class->meta->new_object($args); } sub DESTROY { my $self = shift; return unless $self->can('DEMOLISH'); # short circuit my $e = do{ local $?; local $@; eval{ # DEMOLISHALL # 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 ;) foreach my $class (@{ Mouse::Util::get_linear_isa(ref $self) }) { my $demolish = Mouse::Util::get_code_ref($class, 'DEMOLISH') || next; $self->$demolish(Mouse::Util::in_global_destruction()); } }; $@; }; no warnings 'misc'; die $e if $e; # rethrow } sub BUILDALL { my $self = shift; # short circuit return unless $self->can('BUILD'); for my $class (reverse $self->meta->linearized_isa) { my $build = Mouse::Util::get_code_ref($class, 'BUILD') || next; $self->$build(@_); } return; } sub DEMOLISHALL; *DEMOLISHALL = \&DESTROY; 1; __END__ =head1 NAME Mouse::PurePerl - A Mouse guts in pure Perl =head1 VERSION This document describes Mouse version 2.1.0 =head1 SEE ALSO L =cut Role.pm000644000765000024 1267612245117717 15072 0ustar00gfxstaff000000000000Mouse-2.1.0/lib/Mousepackage Mouse::Role; use Mouse::Exporter; # enables strict and warnings our $VERSION = '2.1.0'; use Carp (); use Scalar::Util (); use Mouse (); Mouse::Exporter->setup_import_methods( as_is => [qw( extends with has before after around override super augment inner requires excludes ), \&Scalar::Util::blessed, \&Carp::confess, ], ); sub extends { Carp::croak "Roles do not support 'extends'"; } sub with { Mouse::Util::apply_all_roles(scalar(caller), @_); return; } sub has { my $meta = Mouse::Meta::Role->initialize(scalar caller); my $name = shift; $meta->throw_error(q{Usage: has 'name' => ( key => value, ... )}) if @_ % 2; # odd number of arguments for my $n(ref($name) ? @{$name} : $name){ $meta->add_attribute($n => @_); } return; } sub before { my $meta = Mouse::Meta::Role->initialize(scalar caller); my $code = pop; for my $name($meta->_collect_methods(@_)) { $meta->add_before_method_modifier($name => $code); } return; } sub after { my $meta = Mouse::Meta::Role->initialize(scalar caller); my $code = pop; for my $name($meta->_collect_methods(@_)) { $meta->add_after_method_modifier($name => $code); } return; } sub around { my $meta = Mouse::Meta::Role->initialize(scalar caller); my $code = pop; for my $name($meta->_collect_methods(@_)) { $meta->add_around_method_modifier($name => $code); } return; } sub super { return if !defined $Mouse::SUPER_BODY; $Mouse::SUPER_BODY->(@Mouse::SUPER_ARGS); } sub override { # my($name, $code) = @_; Mouse::Meta::Role->initialize(scalar caller)->add_override_method_modifier(@_); return; } # We keep the same errors messages as Moose::Role emits, here. sub inner { Carp::croak "Roles cannot support 'inner'"; } sub augment { Carp::croak "Roles cannot support 'augment'"; } sub requires { my $meta = Mouse::Meta::Role->initialize(scalar caller); $meta->throw_error("Must specify at least one method") unless @_; $meta->add_required_methods(@_); return; } sub excludes { Mouse::Util::not_supported(); } sub init_meta{ shift; my %args = @_; my $class = $args{for_class} or Carp::confess("Cannot call init_meta without specifying a for_class"); my $metaclass = $args{metaclass} || 'Mouse::Meta::Role'; my $meta = $metaclass->initialize($class); $meta->add_method(meta => sub{ $metaclass->initialize(ref($_[0]) || $_[0]); }); # make a role type for each Mouse role Mouse::Util::TypeConstraints::role_type($class) unless Mouse::Util::TypeConstraints::find_type_constraint($class); return $meta; } 1; __END__ =head1 NAME Mouse::Role - The Mouse Role =head1 VERSION This document describes Mouse version 2.1.0 =head1 SYNOPSIS package Comparable; use Mouse::Role; # the package is now a Mouse role # Declare methods that are required by this role requires qw(compare); # Define methods this role provides sub equals { my($self, $other) = @_; return $self->compare($other) == 0; } # and later package MyObject; use Mouse; with qw(Comparable); # Now MyObject can equals() sub compare { # ... } my $foo = MyObject->new(); my $bar = MyObject->new(); $obj->equals($bar); # yes, it is comparable =head1 DESCRIPTION This module declares the caller class to be a Mouse role. The concept of roles is documented in L. This document serves as API documentation. =head1 EXPORTED FUNCTIONS Mouse::Role supports all of the functions that Mouse exports, but differs slightly in how some items are handled (see L below for details). Mouse::Role also offers two role-specific keywords: =head2 C<< requires(@method_names) >> 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. =head2 C<< excludes(@role_names) >> This is exported but not implemented in Mouse. =head1 IMPORT AND UNIMPORT =head2 import Importing Mouse::Role will give you sugar. C<-traits> are also supported. =head2 unimport Please unimport (C<< no Mouse::Role >>) so that if someone calls one of the keywords (such as L) it will break loudly instead breaking subtly. =head1 CAVEATS Role support has only a few caveats: =over =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 Mouse 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 SEE ALSO L L L L =cut Spec.pm000644000765000024 702512245117717 15033 0ustar00gfxstaff000000000000Mouse-2.1.0/lib/Mousepackage Mouse::Spec; use strict; use warnings; our $VERSION = '2.1.0'; our $MouseVersion = $VERSION; our $MooseVersion = '1.13'; sub MouseVersion{ $MouseVersion } sub MooseVersion{ $MooseVersion } 1; __END__ =head1 NAME Mouse::Spec - To what extent Mouse is compatible with Moose =head1 VERSION This document describes Mouse version 2.1.0 =head1 SYNOPSIS use Mouse::Spec; printf "Mouse/%s is compatible with Moose/%s\n", Mouse::Spec->MouseVersion, Mouse::Spec->MooseVersion; =head1 DESCRIPTION Mouse is a subset of Moose. This document describes to what extend Mouse is compatible (and incompatible) with Moose. =head2 Compatibility with Moose =head3 Sugary APIs The sugary APIs are highly compatible with Moose. Methods which have the same name as Moose's are expected to be compatible with Moose's. =head3 Meta object protocols Meta object protocols are a subset of the counterpart of Moose. Their methods which have the same name as Moose's are expected to be compatible with Moose's. Feel free to use these methods even if they are not documented. However, there are differences between Moose's MOP and Mouse's. For example, meta object protocols in Mouse have no attributes by default, so C<< $metaclass->meta->make_immutable() >> will not work as you expect. B. =head3 Mouse::Meta::Instance Meta instance mechanism is not implemented, so you cannot change the reftype of Mouse objects in the same way as Moose. =head3 Role exclusion Role exclusion, C, is not implemented. =head3 -metaclass in Mouse::Exporter C<< use Mouse -metaclass => ... >> are not implemented. Use C<< use Mouse -traits => ... >> instead. =head3 Mouse::Meta::Attribute::Native Native traits are not supported directly, but C is available on CPAN. Once you have installed it, you can use it as the same way in Moose. That is, native traits are automatically loaded by Mouse. See L for details. =head2 Notes about Moose::Cookbook Many recipes in L fit L, including: =over 4 =item * L - The (always classic) B example =item * L - A simple B example =item * L - A lazy B example =item * L - Subtypes, and modeling a simple B class hierarchy =item * L - More subtypes, coercion in a B class =item * L - The augment/inner example =item * L - Making Moose fast with immutable =item * L - Builder methods and lazy_build =item * L - Operator overloading, subtypes, and coercion =item * L - Using BUILDARGS and BUILD to hook into object construction =item * L - The Moose::Role example =item * L - Advanced Role Composition - method exclusion and aliasing =item * L - Applying a role to an object instance =item * L - A meta-attribute, attributes with labels =item * L - Labels implemented via attribute traits =item * L - Providing an alternate base object class =back =head1 SEE ALSO L L L L =cut Tiny.pod000644000765000024 53412245117717 15210 0ustar00gfxstaff000000000000Mouse-2.1.0/lib/Mouse =head1 NAME Mouse::Tiny - Mouse in a single file =head1 VERSION This document describes Mouse version 2.0.0 =head1 DESCRIPTION Mouse::Tiny is Mouse, but it is in a single file. This is B tiny. In fact, it requires a little more memory and time than Mouse. Use Mouse unless you know what you are doing. =head1 SEE ALSO L =cut TypeRegistry.pm000644000765000024 125212245117717 16607 0ustar00gfxstaff000000000000Mouse-2.1.0/lib/Mousepackage Mouse::TypeRegistry; use Mouse::Util::TypeConstraints; sub import { warn "Mouse::TypeRegistry is deprecated, please use Mouse::Util::TypeConstraints instead."; shift @_; unshift @_, 'Mouse::Util::TypeConstraints'; goto \&Mouse::Util::TypeConstraints::import; } sub unimport { warn "Mouse::TypeRegistry is deprecated, please use Mouse::Util::TypeConstraints instead."; shift @_; unshift @_, 'Mouse::Util::TypeConstraints'; goto \&Mouse::Util::TypeConstraints::unimport; } 1; __END__ =head1 NAME Mouse::TypeRegistry - (DEPRECATED) =head1 DESCRIPTION Mouse::TypeRegistry is deprecated. Use Mouse::Util::TypeConstraints instead. =cut Util.pm000644000765000024 3112412245117717 15073 0ustar00gfxstaff000000000000Mouse-2.1.0/lib/Mousepackage Mouse::Util; use Mouse::Exporter; # enables strict and warnings # Note that those which don't exist here are defined in XS or Mouse::PurePerl # must be here because it will be referred by other modules loaded sub get_linear_isa($;$); ## no critic # must be here because it will called in Mouse::Exporter sub install_subroutines { my $into = shift; while(my($name, $code) = splice @_, 0, 2){ no strict 'refs'; no warnings 'once', 'redefine'; use warnings FATAL => 'uninitialized'; *{$into . '::' . $name} = \&{$code}; } return; } BEGIN{ # This is used in Mouse::PurePerl Mouse::Exporter->setup_import_methods( as_is => [qw( find_meta does_role resolve_metaclass_alias apply_all_roles english_list load_class is_class_loaded get_linear_isa get_code_info get_code_package get_code_ref not_supported does meta throw_error dump )], groups => { default => [], # export no functions by default # The ':meta' group is 'use metaclass' for Mouse meta => [qw(does meta dump throw_error)], }, ); our $VERSION = '2.1.0'; my $xs = !(defined(&is_valid_class_name) || $ENV{MOUSE_PUREPERL} || $ENV{PERL_ONLY}); # Because Mouse::Util is loaded first in all the Mouse sub-modules, # XSLoader must be placed here, not in Mouse.pm. if($xs){ # XXX: XSLoader tries to get the object path from caller's file name # $hack_mouse_file fools its mechanism (my $hack_mouse_file = __FILE__) =~ s/.Util//; # .../Mouse/Util.pm -> .../Mouse.pm $xs = eval sprintf("#line %d %s\n", __LINE__, $hack_mouse_file) . q{ local $^W = 0; # workaround 'redefine' warning to &install_subroutines require XSLoader; XSLoader::load('Mouse', $VERSION); Mouse::Util->import({ into => 'Mouse::Meta::Method::Constructor::XS' }, ':meta'); Mouse::Util->import({ into => 'Mouse::Meta::Method::Destructor::XS' }, ':meta'); Mouse::Util->import({ into => 'Mouse::Meta::Method::Accessor::XS' }, ':meta'); return 1; } || 0; warn $@ if $@ && $ENV{MOUSE_XS}; } if(!$xs){ require 'Mouse/PurePerl.pm'; # we don't want to create its namespace } *MOUSE_XS = sub(){ $xs }; # definition of mro::get_linear_isa() my $get_linear_isa; if ($] >= 5.010_000) { require 'mro.pm'; $get_linear_isa = \&mro::get_linear_isa; } else { # this code is based on MRO::Compat::__get_linear_isa my $_get_linear_isa_dfs; # this recurses so it isn't pretty $_get_linear_isa_dfs = sub { my($classname) = @_; my @lin = ($classname); my %stored; no strict 'refs'; foreach my $parent (@{"$classname\::ISA"}) { foreach my $p(@{ $_get_linear_isa_dfs->($parent) }) { next if exists $stored{$p}; push(@lin, $p); $stored{$p} = 1; } } return \@lin; }; { package # hide from PAUSE Class::C3; our %MRO; # avoid 'once' warnings } # MRO::Compat::__get_linear_isa has no prototype, so # we define a prototyped version for compatibility with core's # See also MRO::Compat::__get_linear_isa. $get_linear_isa = sub ($;$){ my($classname, $type) = @_; if(!defined $type){ $type = exists $Class::C3::MRO{$classname} ? 'c3' : 'dfs'; } if($type eq 'c3'){ require Class::C3; return [Class::C3::calculateMRO($classname)]; } else{ return $_get_linear_isa_dfs->($classname); } }; } *get_linear_isa = $get_linear_isa; } use Carp (); use Scalar::Util (); # aliases as public APIs # it must be 'require', not 'use', because Mouse::Meta::Module depends on Mouse::Util require Mouse::Meta::Module; # for the entities of metaclass cache utilities # aliases { *class_of = \&Mouse::Meta::Module::_class_of; *get_metaclass_by_name = \&Mouse::Meta::Module::_get_metaclass_by_name; *get_all_metaclass_instances = \&Mouse::Meta::Module::_get_all_metaclass_instances; *get_all_metaclass_names = \&Mouse::Meta::Module::_get_all_metaclass_names; *Mouse::load_class = \&load_class; *Mouse::is_class_loaded = \&is_class_loaded; # is-a predicates #generate_isa_predicate_for('Mouse::Meta::TypeConstraint' => 'is_a_type_constraint'); #generate_isa_predicate_for('Mouse::Meta::Class' => 'is_a_metaclass'); #generate_isa_predicate_for('Mouse::Meta::Role' => 'is_a_metarole'); # duck type predicates generate_can_predicate_for(['_compiled_type_constraint'] => 'is_a_type_constraint'); generate_can_predicate_for(['create_anon_class'] => 'is_a_metaclass'); generate_can_predicate_for(['create_anon_role'] => 'is_a_metarole'); } sub in_global_destruction; if (defined ${^GLOBAL_PHASE}) { *in_global_destruction = sub { return ${^GLOBAL_PHASE} eq 'DESTRUCT'; }; } else { my $in_global_destruction = 0; END { $in_global_destruction = 1 } *in_global_destruction = sub { return $in_global_destruction; }; } # Moose::Util compatible utilities sub find_meta{ return class_of( $_[0] ); } sub _does_role_impl { my ($class_or_obj, $role_name) = @_; my $meta = class_of($class_or_obj); (defined $role_name) || ($meta || 'Mouse::Meta::Class')->throw_error("You must supply a role name to does()"); return defined($meta) && $meta->does_role($role_name); } sub does_role { my($thing, $role_name) = @_; if( (Scalar::Util::blessed($thing) || is_class_loaded($thing)) && $thing->can('does')) { return $thing->does($role_name); } goto &_does_role_impl; } # taken from Mouse::Util (0.90) { 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} ||= do{ my $possible_full_name = join '::', 'Mouse::Meta', $type, 'Custom', ($options{trait} ? 'Trait' : ()), $metaclass_name ; my $loaded_class = load_first_existing_class( $possible_full_name, $metaclass_name ); $loaded_class->can('register_implementation') ? $loaded_class->register_implementation : $loaded_class; }; } } # Utilities from Class::MOP sub get_code_info; sub get_code_package; sub is_valid_class_name; sub is_class_loaded; # taken from Class/MOP.pm sub load_first_existing_class { my @classes = @_ or return; my %exceptions; for my $class (@classes) { my $e = _try_load_one_class($class); if ($e) { $exceptions{$class} = $e; } else { return $class; } } # not found Carp::confess join( "\n", map { sprintf( "Could not load class (%s) because : %s", $_, $exceptions{$_} ) } @classes ); } # taken from Class/MOP.pm sub _try_load_one_class { my $class = shift; unless ( is_valid_class_name($class) ) { my $display = defined($class) ? $class : 'undef'; Carp::confess "Invalid class name ($display)"; } return '' if is_class_loaded($class); $class =~ s{::}{/}g; $class .= '.pm'; return do { local $@; eval { require $class }; $@; }; } sub load_class { my $class = shift; my $e = _try_load_one_class($class); Carp::confess "Could not load class ($class) because : $e" if $e; return $class; } sub apply_all_roles { my $consumer = Scalar::Util::blessed($_[0]) ? $_[0] # instance : Mouse::Meta::Class->initialize($_[0]); # class or role name my @roles; # Basis of Data::OptList my $max = scalar(@_); for (my $i = 1; $i < $max ; $i++) { my $role = $_[$i]; my $role_name; if(ref $role) { $role_name = $role->name; } else { $role_name = $role; load_class($role_name); $role = get_metaclass_by_name($role_name); } if ($i + 1 < $max && ref($_[$i + 1]) eq 'HASH') { push @roles, [ $role => $_[++$i] ]; } else { push @roles, [ $role => undef ]; } is_a_metarole($role) || $consumer->meta->throw_error("You can only consume roles, $role_name is not a Mouse role"); } if ( scalar @roles == 1 ) { my ( $role, $params ) = @{ $roles[0] }; $role->apply( $consumer, defined $params ? $params : () ); } else { Mouse::Meta::Role->combine(@roles)->apply($consumer); } return; } # taken from Moose::Util 0.90 sub english_list { return $_[0] if @_ == 1; my @items = sort @_; return "$items[0] and $items[1]" if @items == 2; my $tail = pop @items; return join q{, }, @items, "and $tail"; } sub quoted_english_list { return english_list(map { qq{'$_'} } @_); } # common utilities sub not_supported{ my($feature) = @_; $feature ||= ( caller(1) )[3] . '()'; # subroutine name local $Carp::CarpLevel = $Carp::CarpLevel + 1; Carp::confess("Mouse does not currently support $feature"); } # general meta() method sub meta :method{ return Mouse::Meta::Class->initialize(ref($_[0]) || $_[0]); } # general throw_error() method # $o->throw_error($msg, depth => $leve, longmess => $croak_or_confess) sub throw_error :method { my($self, $message, %args) = @_; local $Carp::CarpLevel = $Carp::CarpLevel + 1 + ($args{depth} || 0); local $Carp::MaxArgNums = 20; # default is 8, usually we use named args which gets messier though if(exists $args{longmess} && !$args{longmess}) { Carp::croak($message); } else{ Carp::confess($message); } } # general dump() method sub dump :method { my($self, $maxdepth) = @_; require 'Data/Dumper.pm'; # we don't want to create its namespace my $dd = Data::Dumper->new([$self]); $dd->Maxdepth(defined($maxdepth) ? $maxdepth : 3); $dd->Indent(1); $dd->Sortkeys(1); $dd->Quotekeys(0); return $dd->Dump(); } # general does() method sub does :method { goto &_does_role_impl; } 1; __END__ =head1 NAME Mouse::Util - Utilities for working with Mouse classes =head1 VERSION This document describes Mouse version 2.1.0 =head1 SYNOPSIS use Mouse::Util; # turns on strict and warnings =head1 DESCRIPTION This module provides a set of utility functions. Many of these functions are intended for use in Mouse itself or MouseX modules, but some of them may be useful for use in your own code. =head1 IMPLEMENTATIONS FOR =head2 Moose::Util functions The following functions are exportable. =head3 C The same as C. =head3 C =head3 C =head3 C =head3 C =head2 Class::MOP functions The following functions are not exportable. =head3 C<< Mouse::Util::is_class_loaded($classname) -> Bool >> Returns whether I<$classname> is actually loaded or not. It uses a heuristic which involves checking for the existence of C<$VERSION>, C<@ISA>, and any locally-defined method. =head3 C<< Mouse::Util::load_class($classname) -> ClassName >> This will load a given I<$classname> (or die if it is not loadable). This function can be used in place of tricks like C or using C. =head3 C<< Mouse::Util::class_of($classname_or_object) -> MetaClass >> =head3 C<< Mouse::Util::get_metaclass_by_name($classname) -> MetaClass >> =head3 C<< Mouse::Util::get_all_metaclass_instances() -> (MetaClasses) >> =head3 C<< Mouse::Util::get_all_metaclass_names() -> (ClassNames) >> =head2 mro (or MRO::Compat) =head3 C =head2 Sub::Identify =head3 C =head1 Mouse specific utilities =head3 C =head3 C =head3 C =head1 SEE ALSO L L L L L =cut MetaRole.pm000644000765000024 1554612245117717 16615 0ustar00gfxstaff000000000000Mouse-2.1.0/lib/Mouse/Utilpackage Mouse::Util::MetaRole; use Mouse::Util; # enables strict and warnings use Scalar::Util (); sub apply_metaclass_roles { my %args = @_; _fixup_old_style_args(\%args); return apply_metaroles(%args); } sub apply_metaroles { my %args = @_; my $for = Scalar::Util::blessed($args{for}) ? $args{for} : Mouse::Util::get_metaclass_by_name( $args{for} ); if(!$for){ Carp::confess("You must pass an initialized class, but '$args{for}' has no metaclass"); } if ( Mouse::Util::is_a_metarole($for) ) { return _make_new_metaclass( $for, $args{role_metaroles}, 'role' ); } else { return _make_new_metaclass( $for, $args{class_metaroles}, 'class' ); } } sub _make_new_metaclass { my($for, $roles, $primary) = @_; return $for unless keys %{$roles}; my $new_metaclass = exists($roles->{$primary}) ? _make_new_class( ref $for, $roles->{$primary} ) # new class with traits : ref $for; my %classes; for my $key ( grep { $_ ne $primary } keys %{$roles} ) { my $metaclass; my $attr = $for->can($metaclass = ($key . '_metaclass')) || $for->can($metaclass = ($key . '_class')) || $for->throw_error("Unknown metaclass '$key'"); $classes{ $metaclass } = _make_new_class( $for->$attr(), $roles->{$key} ); } return $new_metaclass->reinitialize( $for, %classes ); } sub _fixup_old_style_args { my $args = shift; return if $args->{class_metaroles} || $args->{roles_metaroles}; $args->{for} = delete $args->{for_class} if exists $args->{for_class}; my @old_keys = qw( attribute_metaclass_roles method_metaclass_roles wrapped_method_metaclass_roles instance_metaclass_roles constructor_class_roles destructor_class_roles error_class_roles application_to_class_class_roles application_to_role_class_roles application_to_instance_class_roles application_role_summation_class_roles ); my $for = Scalar::Util::blessed($args->{for}) ? $args->{for} : Mouse::Util::get_metaclass_by_name( $args->{for} ); my $top_key; if( Mouse::Util::is_a_metaclass($for) ){ $top_key = 'class_metaroles'; $args->{class_metaroles}{class} = delete $args->{metaclass_roles} if exists $args->{metaclass_roles}; } else { $top_key = 'role_metaroles'; $args->{role_metaroles}{role} = delete $args->{metaclass_roles} if exists $args->{metaclass_roles}; } for my $old_key (@old_keys) { my ($new_key) = $old_key =~ /^(.+)_(?:class|metaclass)_roles$/; $args->{$top_key}{$new_key} = delete $args->{$old_key} if exists $args->{$old_key}; } return; } sub apply_base_class_roles { my %options = @_; my $for = $options{for_class}; my $meta = Mouse::Util::class_of($for); my $new_base = _make_new_class( $for, $options{roles}, [ $meta->superclasses() ], ); $meta->superclasses($new_base) if $new_base ne $meta->name(); return; } sub _make_new_class { my($existing_class, $roles, $superclasses) = @_; if(!$superclasses){ return $existing_class if !$roles; my $meta = Mouse::Meta::Class->initialize($existing_class); return $existing_class if !grep { !ref($_) && !$meta->does_role($_) } @{$roles}; } return Mouse::Meta::Class->create_anon_class( superclasses => $superclasses ? $superclasses : [$existing_class], roles => $roles, cache => 1, )->name(); } 1; __END__ =head1 NAME Mouse::Util::MetaRole - Apply roles to any metaclass, as well as the object base class =head1 SYNOPSIS package MyApp::Mouse; use Mouse (); use Mouse::Exporter; use Mouse::Util::MetaRole; use MyApp::Role::Meta::Class; use MyApp::Role::Meta::Method::Constructor; use MyApp::Role::Object; Mouse::Exporter->setup_import_methods( also => 'Mouse' ); sub init_meta { shift; my %args = @_; Mouse->init_meta(%args); Mouse::Util::MetaRole::apply_metaroles( for => $args{for_class}, class_metaroles => { class => ['MyApp::Role::Meta::Class'], constructor => ['MyApp::Role::Meta::Method::Constructor'], }, ); Mouse::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 Mouse extensions write extensions that are able to cooperate with other Mouse 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 B. The process of applying roles to the metaclass reinitializes the metaclass object, which wipes out any existing attributes already defined. However, as long as you do this when your module is imported, the caller should not have any attributes defined yet. The easiest way to ensure that this happens is to use 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 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 constructor =item destructor =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 method =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 SEE ALSO L =cut TypeConstraints.pm000644000765000024 4074212245117717 20252 0ustar00gfxstaff000000000000Mouse-2.1.0/lib/Mouse/Utilpackage Mouse::Util::TypeConstraints; use Mouse::Util; # enables strict and warnings use Mouse::Meta::TypeConstraint; use Mouse::Exporter; use Carp (); use Scalar::Util (); Mouse::Exporter->setup_import_methods( as_is => [qw( as where message optimize_as from via type subtype class_type role_type maybe_type duck_type enum coerce find_type_constraint register_type_constraint )], ); our @CARP_NOT = qw(Mouse::Meta::Attribute); my %TYPE; # The root type $TYPE{Any} = Mouse::Meta::TypeConstraint->new( name => 'Any', ); my @builtins = ( # $name => $parent, $code, # the base type Item => 'Any', undef, # the maybe[] type Maybe => 'Item', undef, # value types Undef => 'Item', \&Undef, Defined => 'Item', \&Defined, Bool => 'Item', \&Bool, Value => 'Defined', \&Value, Str => 'Value', \&Str, Num => 'Str', \&Num, Int => 'Num', \&Int, # ref types Ref => 'Defined', \&Ref, ScalarRef => 'Ref', \&ScalarRef, ArrayRef => 'Ref', \&ArrayRef, HashRef => 'Ref', \&HashRef, CodeRef => 'Ref', \&CodeRef, RegexpRef => 'Ref', \&RegexpRef, GlobRef => 'Ref', \&GlobRef, # object types FileHandle => 'GlobRef', \&FileHandle, Object => 'Ref', \&Object, # special string types ClassName => 'Str', \&ClassName, RoleName => 'ClassName', \&RoleName, ); while (my ($name, $parent, $code) = splice @builtins, 0, 3) { $TYPE{$name} = Mouse::Meta::TypeConstraint->new( name => $name, parent => $TYPE{$parent}, optimized => $code, ); } # parametarizable types $TYPE{Maybe} {constraint_generator} = \&_parameterize_Maybe_for; $TYPE{ArrayRef}{constraint_generator} = \&_parameterize_ArrayRef_for; $TYPE{HashRef} {constraint_generator} = \&_parameterize_HashRef_for; # sugars sub as ($) { (as => $_[0]) } ## no critic sub where (&) { (where => $_[0]) } ## no critic sub message (&) { (message => $_[0]) } ## no critic sub optimize_as (&) { (optimize_as => $_[0]) } ## no critic sub from { @_ } sub via (&) { $_[0] } ## no critic # type utilities sub optimized_constraints { # DEPRECATED Carp::cluck('optimized_constraints() has been deprecated'); return \%TYPE; } undef @builtins; # free the allocated memory @builtins = keys %TYPE; # reuse it sub list_all_builtin_type_constraints { @builtins } sub list_all_type_constraints { keys %TYPE } sub _define_type { my $is_subtype = shift; my $name; my %args; if(@_ == 1 && ref $_[0] ){ # @_ : { name => $name, where => ... } %args = %{$_[0]}; } elsif(@_ == 2 && ref $_[1]) { # @_ : $name => { where => ... } $name = $_[0]; %args = %{$_[1]}; } elsif(@_ % 2) { # @_ : $name => ( where => ... ) ($name, %args) = @_; } else{ # @_ : (name => $name, where => ...) %args = @_; } if(!defined $name){ $name = $args{name}; } $args{name} = $name; my $parent = delete $args{as}; if($is_subtype && !$parent){ $parent = delete $args{name}; $name = undef; } if(defined $parent) { $args{parent} = find_or_create_isa_type_constraint($parent); } if(defined $name){ # set 'package_defined_in' only if it is not a core package my $this = $args{package_defined_in}; if(!$this){ $this = caller(1); if($this !~ /\A Mouse \b/xms){ $args{package_defined_in} = $this; } } if(defined $TYPE{$name}){ my $that = $TYPE{$name}->{package_defined_in} || __PACKAGE__; if($this ne $that) { my $note = ''; if($that eq __PACKAGE__) { $note = sprintf " ('%s' is %s type constraint)", $name, scalar(grep { $name eq $_ } list_all_builtin_type_constraints()) ? 'a builtin' : 'an implicitly created'; } Carp::croak("The type constraint '$name' has already been created in $that" . " and cannot be created again in $this" . $note); } } } $args{constraint} = delete $args{where} if exists $args{where}; $args{optimized} = delete $args{optimized_as} if exists $args{optimized_as}; my $constraint = Mouse::Meta::TypeConstraint->new(%args); if(defined $name){ return $TYPE{$name} = $constraint; } else{ return $constraint; } } sub type { return _define_type 0, @_; } sub subtype { return _define_type 1, @_; } sub coerce { # coerce $type, from $from, via { ... }, ... my $type_name = shift; my $type = find_type_constraint($type_name) or Carp::croak("Cannot find type '$type_name', perhaps you forgot to load it"); $type->_add_type_coercions(@_); return; } sub class_type { my($name, $options) = @_; my $class = $options->{class} || $name; # ClassType return subtype $name => ( as => 'Object', optimized_as => Mouse::Util::generate_isa_predicate_for($class), class => $class, ); } sub role_type { my($name, $options) = @_; my $role = $options->{role} || $name; # RoleType return subtype $name => ( as => 'Object', optimized_as => sub { return Scalar::Util::blessed($_[0]) && Mouse::Util::does_role($_[0], $role); }, role => $role, ); } sub maybe_type { my $param = shift; return _find_or_create_parameterized_type($TYPE{Maybe}, $param); } sub duck_type { my($name, @methods); if(ref($_[0]) ne 'ARRAY'){ $name = shift; } @methods = (@_ == 1 && ref($_[0]) eq 'ARRAY') ? @{$_[0]} : @_; # DuckType return _define_type 1, $name => ( as => 'Object', optimized_as => Mouse::Util::generate_can_predicate_for(\@methods), message => sub { my($object) = @_; my @missing = grep { !$object->can($_) } @methods; return ref($object) . ' is missing methods ' . Mouse::Util::quoted_english_list(@missing); }, methods => \@methods, ); } sub enum { my($name, %valid); if(!(@_ == 1 && ref($_[0]) eq 'ARRAY')){ $name = shift; } %valid = map{ $_ => undef } (@_ == 1 && ref($_[0]) eq 'ARRAY' ? @{$_[0]} : @_); # EnumType return _define_type 1, $name => ( as => 'Str', optimized_as => sub{ return defined($_[0]) && !ref($_[0]) && exists $valid{$_[0]}; }, ); } sub _find_or_create_regular_type{ my($spec, $create) = @_; return $TYPE{$spec} if exists $TYPE{$spec}; my $meta = Mouse::Util::get_metaclass_by_name($spec); if(!defined $meta){ return $create ? class_type($spec) : undef; } if(Mouse::Util::is_a_metarole($meta)){ return role_type($spec); } else{ return class_type($spec); } } sub _find_or_create_parameterized_type{ my($base, $param) = @_; my $name = sprintf '%s[%s]', $base->name, $param->name; $TYPE{$name} ||= $base->parameterize($param, $name); } sub _find_or_create_union_type{ return if grep{ not defined } @_; # all things must be defined my @types = sort map{ $_->{type_constraints} ? @{$_->{type_constraints}} : $_ } @_; my $name = join '|', @types; # UnionType $TYPE{$name} ||= Mouse::Meta::TypeConstraint->new( name => $name, type_constraints => \@types, ); } # The type parser # param : '[' type ']' | NOTHING sub _parse_param { my($c) = @_; if($c->{spec} =~ s/^\[//){ my $type = _parse_type($c, 1); if($c->{spec} =~ s/^\]//){ return $type; } Carp::croak("Syntax error in type: missing right square bracket in '$c->{orig}'"); } return undef; } # name : [\w.:]+ sub _parse_name { my($c, $create) = @_; if($c->{spec} =~ s/\A ([\w.:]+) //xms){ return _find_or_create_regular_type($1, $create); } Carp::croak("Syntax error in type: expect type name near '$c->{spec}' in '$c->{orig}'"); } # single_type : name param sub _parse_single_type { my($c, $create) = @_; my $type = _parse_name($c, $create); my $param = _parse_param($c); if(defined $type){ if(defined $param){ return _find_or_create_parameterized_type($type, $param); } else { return $type; } } elsif(defined $param){ Carp::croak("Undefined type with parameter [$param] in '$c->{orig}'"); } else{ return undef; } } # type : single_type ('|' single_type)* sub _parse_type { my($c, $create) = @_; my $type = _parse_single_type($c, $create); if($c->{spec}){ # can be an union type my @types; while($c->{spec} =~ s/^\|//){ push @types, _parse_single_type($c, $create); } if(@types){ return _find_or_create_union_type($type, @types); } } return $type; } sub find_type_constraint { my($spec) = @_; return $spec if Mouse::Util::is_a_type_constraint($spec) or not defined $spec; $spec =~ s/\s+//g; return $TYPE{$spec}; } sub register_type_constraint { my($constraint) = @_; Carp::croak("No type supplied / type is not a valid type constraint") unless Mouse::Util::is_a_type_constraint($constraint); return $TYPE{$constraint->name} = $constraint; } sub find_or_parse_type_constraint { my($spec) = @_; return $spec if Mouse::Util::is_a_type_constraint($spec) or not defined $spec; $spec =~ tr/ \t\r\n//d; my $tc = $TYPE{$spec}; if(defined $tc) { return $tc; } my %context = ( spec => $spec, orig => $spec, ); $tc = _parse_type(\%context); if($context{spec}){ Carp::croak("Syntax error: extra elements '$context{spec}' in '$context{orig}'"); } return $TYPE{$spec} = $tc; } sub find_or_create_does_type_constraint{ # XXX: Moose does not register a new role_type, but Mouse does. my $tc = find_or_parse_type_constraint(@_); return defined($tc) ? $tc : role_type(@_); } sub find_or_create_isa_type_constraint { # XXX: Moose does not register a new class_type, but Mouse does. my $tc = find_or_parse_type_constraint(@_); return defined($tc) ? $tc : class_type(@_); } 1; __END__ =head1 NAME Mouse::Util::TypeConstraints - Type constraint system for Mouse =head1 VERSION This document describes Mouse version 2.1.0 =head2 SYNOPSIS use Mouse::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+$_ }; enum 'RGBColors' => qw(red green blue); no Mouse::Util::TypeConstraints; =head1 DESCRIPTION This module provides Mouse 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 Mouse 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 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 Maybe[Str] # value may be a string, may be undefined If Mouse 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 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'>. The C constraint checks that an I the named role. =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 it's 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 Mouse. 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) ) }; Here is an example of using L and it's non-test related C function. type 'ArrayOfHashOfBarsAndRandomNumbers' => where { eq_deeply($_, array_each(subhashof({ bar => isa('Bar'), random_number => ignore() }))) }; =head1 METHODS =head2 C<< list_all_builtin_type_constraints -> (Names) >> Returns the names of builtin type constraints. =head2 C<< list_all_type_constraints -> (Names) >> Returns the names of all the type constraints. =head1 FUNCTIONS =over 4 =item C<< type $name => where { } ... -> Mouse::Meta::TypeConstraint >> =item C<< subtype $name => as $parent => where { } ... -> Mouse::Meta::TypeConstraint >> =item C<< subtype as $parent => where { } ... -> Mouse::Meta::TypeConstraint >> =item C<< class_type ($class, ?$options) -> Mouse::Meta::TypeConstraint >> =item C<< role_type ($role, ?$options) -> Mouse::Meta::TypeConstraint >> =item C<< duck_type($name, @methods | \@methods) -> Mouse::Meta::TypeConstraint >> =item C<< duck_type(\@methods) -> Mouse::Meta::TypeConstraint >> =item C<< enum($name, @values | \@values) -> Mouse::Meta::TypeConstraint >> =item C<< enum (\@values) -> Mouse::Meta::TypeConstraint >> =item C<< coerce $type => from $another_type, via { }, ... >> =back =over 4 =item C<< find_type_constraint(Type) -> Mouse::Meta::TypeConstraint >> =back =head1 THANKS Much of this documentation was taken from C =head1 SEE ALSO L =cut XS.pod000644000765000024 270012245117717 14634 0ustar00gfxstaff000000000000Mouse-2.1.0/lib/Mouse =head1 NAME Mouse::XS - A Mouse guts in XS =head1 VERSION This document describes Mouse version 2.0.0 =head1 DESCRIPTION Mouse has an optional XS implementation, which is automatically built and used if available. According to benchmarks, this is about 2 times faster than Mouse::PurePerl. =head2 INSTALL The XS implementation are selected by default, but you can force it by passing the C<--xs> option to F. perl Makefile.PL --xs If you do not want to build the XS implementation, you can pass the C<--pp> option to F. perl Makefile.PL --pp Or if you use C (>= 1.7), you can give C<--pp> option to C. cpanm --pp Mouse =head2 The MOUSE_PUREPERL (or PERL_ONLY) environment variable It can be used to enable the use of Mouse::PurePerl in order to test and debug programs that use Mouse. =head1 CAVEAT There are some Mouse::XS specific features. =over =item Mutationg references to the return values of getters When you take a reference from Mouse getters, like C<< $ref = \$obj->foo >>, the C<$ref> refers C<< \$obj->{foo} >>. That is, mutating C<$$ref> also alters C<< $obj->{foo} >>. The behavior may confuse you so you'd better avoid to take a reference directly from getters. See L for details. =back =head1 DEPENDENCIES The XS implementation requires Perl 5.8.1 or later, and a C compiler. =head1 SEE ALSO L L =cut Squirrel.pm000644000765000024 341512245117717 14656 0ustar00gfxstaff000000000000Mouse-2.1.0/libpackage Squirrel; use strict; use warnings; sub _choose_backend { if ( $INC{"Moose.pm"} ) { return { backend => 'Moose', import => \&Moose::import, unimport => \&Moose::unimport, }; } else { require Mouse; return { backend => 'Mouse', import => \&Mouse::import, unimport => \&Mouse::unimport, }; } } my %pkgs; sub _handlers { my $class = shift; my $caller = caller(1); $pkgs{$caller} ||= $class->_choose_backend; } sub import { require Carp; Carp::carp("Squirrel is deprecated. Please use Any::Moose instead. It fixes a number of design problems that Squirrel has."); my $handlers = shift->_handlers; unshift @_, $handlers->{backend}; goto &{$handlers->{import}}; } sub unimport { my $handlers = shift->_handlers; unshift @_, $handlers->{backend}; goto &{$handlers->{unimport}}; } 1; __END__ =pod =head1 NAME Squirrel - Use Mouse, unless Moose is already loaded. (DEPRECATED) =head1 SYNOPSIS use Squirrel; has goggles => ( is => "rw", ); =head1 DEPRECATION C is deprecated. C provides the same functionality, but better. :) =head1 DESCRIPTION L and L are THE BEST FRIENDS, but if L isn't there L will hang out with L as well. When your own code doesn't actually care whether or not you use L or L you can use either, and let your users decide for you. This lets you run with minimal dependencies and have a faster startup, but if L is already in use you get all the benefits of using that (transformability, introspection, more opportunities for code reuse, etc). =head1 SEE ALSO L =cut Role.pm000644000765000024 146312245117717 15560 0ustar00gfxstaff000000000000Mouse-2.1.0/lib/Squirrelpackage Squirrel::Role; use strict; use warnings; use base qw(Squirrel); sub _choose_backend { if ( $INC{"Moose/Role.pm"} ) { return { backend => 'Moose::Role', import => \&Moose::Role::import, unimport => \&Moose::Role::unimport, } } else { require Mouse::Role; return { backend => 'Mouse::Role', import => \&Mouse::Role::import, unimport => \&Mouse::Role::unimport, } } } 1; __END__ =head1 NAME Squirrel::Role - Use Mouse::Role, unless Moose::Role is already loaded. (DEPRECATED) =head1 SYNOPSIS use Squirrel::Role; =head1 DEPRECATION C is deprecated. C provides the same functionality, but better. :) =head1 SEE ALSO L =cut Mouse.pm000644000765000024 531712245117717 15062 0ustar00gfxstaff000000000000Mouse-2.1.0/lib/Testpackage Test::Mouse; use Mouse::Exporter; use Mouse::Util qw(does_role find_meta); use Test::Builder; Mouse::Exporter->setup_import_methods( as_is => [qw( meta_ok does_ok has_attribute_ok with_immutable )], ); ## the test builder instance ... my $Test = Test::Builder->new; ## exported functions sub meta_ok ($;$) { ## no critic 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 ($$;$) { ## no critic 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 ($$;$) { ## no critic 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 (&@) { ## no critic my $block = shift; my $before = $Test->current_test; $block->(); $_->meta->make_immutable for @_; $block->(); return if not defined wantarray; my $num_tests = $Test->current_test - $before; return !grep{ !$_ } ($Test->summary)[-$num_tests .. -1]; } 1; __END__ =head1 NAME Test::Mouse - Test functions for Mouse specific features =head1 SYNOPSIS use Test::More plan => 1; use Test::Mouse; 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 Mouse 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 I *which should contain normal tests) twice, and make each class in I<@class_names> immutable between the two runs. =back =head1 SEE ALSO L L L =cut ouse.pm000644000765000024 356112245117717 14025 0ustar00gfxstaff000000000000Mouse-2.1.0/libpackage ouse; use Mouse::Util; # enables strict and warnings my $package = 'Class'; sub import { $package = $_[1] || 'Class'; if ($package =~ /^\+/) { $package =~ s/^\+//; Mouse::Util::load_class($package); } } use Filter::Simple sub { s/^/package $package;\nuse Mouse;\nuse Mouse::Util::TypeConstraints;\n/; }; 1; __END__ =head1 NAME ouse - syntactic sugar to make Mouse one-liners easier =head1 SYNOPSIS # create a Mouse class on the fly ... perl -Mouse=Foo -e 'has bar => ( is=>q[ro], default => q[baz] ); print Foo->new->bar' # prints baz # loads an existing class (Mouse or non-Mouse) # and re-"opens" the package definition to make # debugging/introspection easier perl -Mouse=+My::Class -e 'print join ", " => __PACKAGE__->meta->get_method_list' =head1 DESCRIPTION F is a simple source filter that adds C to the beginning of your script and was entirely created because typing perl C<< -e'package Foo; use Mouse; ...' >> was annoying me... especially after getting used to having C<-Moose> for Moose. =head1 INTERFACE C provides exactly one method and it is automatically called by perl: =over 4 =item C<< oose->import() >>> Pass a package name to import to be used by the source filter. =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 SEE ALSO L for C<< perl -Moose -e '...' >> =head1 AUTHOR For all intents and purposes, blame: Chris Prather C<< >> ...who wrote oose.pm, which was adapted for use by Mouse by: Ricardo SIGNES C<< >> =head1 COPYRIGHT AND LICENSE Copyright 2008 Shawn M Moore. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut minil.toml000644000765000024 34112245117717 13724 0ustar00gfxstaff000000000000Mouse-2.1.0name = "Mouse" badges = ["travis"] allow_pureperl=1 [build] build_class = "builder::MyBuilder" [no_index] directory = ["t", "xt", "tool", "author", "example", "benchmarks", "builder"] [ReleaseTest] MinimumVersion = false mouse.h000644000765000024 2466112245117717 13273 0ustar00gfxstaff000000000000Mouse-2.1.0#ifndef MOUSE_H #define MOUSE_H #define PERL_EUPXS_ALWAYS_EXPORT #include "xshelper.h" #ifndef mro_get_linear_isa #define no_mro_get_linear_isa #define mro_get_linear_isa(stash) mouse_mro_get_linear_isa(aTHX_ stash) AV* mouse_mro_get_linear_isa(pTHX_ HV* const stash); #define mro_method_changed_in(stash) ((void)++PL_sub_generation) #endif /* !mro_get_linear_isa */ #ifndef mro_get_pkg_gen #ifdef no_mro_get_linear_isa #define mro_get_pkg_gen(stash) ((void)stash, PL_sub_generation) #else #define mro_get_pkg_gen(stash) (HvAUX(stash)->xhv_mro_meta ? HvAUX(stash)->xhv_mro_meta->pkg_gen : (U32)0) #endif /* !no_mro_get_linear_isa */ #endif /* mro_get_package_gen */ #ifndef GvCV_set #define GvCV_set(gv, cv) (GvCV(gv) = (cv)) #endif extern SV* mouse_package; extern SV* mouse_methods; extern SV* mouse_name; extern SV* mouse_coerce; void mouse_throw_error(SV* const metaobject, SV* const data /* not used */, const char* const fmt, ...) __attribute__format__(__printf__, 3, 4); #if (PERL_BCDVERSION < 0x5014000) /* workaround RT #69939 */ I32 mouse_call_sv_safe(pTHX_ SV*, I32); #else #define mouse_call_sv_safe Perl_call_sv #endif #define call_sv_safe(sv, flags) mouse_call_sv_safe(aTHX_ sv, flags) #define call_method_safe(m, flags) mouse_call_sv_safe(aTHX_ newSVpvn_flags(m, strlen(m), SVs_TEMP), flags | G_METHOD) #define call_method_safes(m, flags) mouse_call_sv_safe(aTHX_ newSVpvs_flags(m, SVs_TEMP), flags | G_METHOD) #define is_class_loaded(sv) mouse_is_class_loaded(aTHX_ sv) bool mouse_is_class_loaded(pTHX_ SV*); #define is_an_instance_of(klass, sv) mouse_is_an_instance_of(aTHX_ gv_stashpvs(klass, GV_ADD), (sv)) #define IsObject(sv) (SvROK(sv) && SvOBJECT(SvRV(sv))) #define IsArrayRef(sv) (SvROK(sv) && !SvOBJECT(SvRV(sv)) && SvTYPE(SvRV(sv)) == SVt_PVAV) #define IsHashRef(sv) (SvROK(sv) && !SvOBJECT(SvRV(sv)) && SvTYPE(SvRV(sv)) == SVt_PVHV) #define IsCodeRef(sv) (SvROK(sv) && !SvOBJECT(SvRV(sv)) && SvTYPE(SvRV(sv)) == SVt_PVCV) #define mcall0(invocant, m) mouse_call0(aTHX_ (invocant), (m)) #define mcall1(invocant, m, arg1) mouse_call1(aTHX_ (invocant), (m), (arg1)) #define predicate_call(invocant, m) mouse_predicate_call(aTHX_ (invocant), (m)) #define mcall0s(invocant, m) mcall0((invocant), sv_2mortal(newSVpvs_share(m))) #define mcall1s(invocant, m, arg1) mcall1((invocant), sv_2mortal(newSVpvs_share(m)), (arg1)) #define predicate_calls(invocant, m) predicate_call((invocant), sv_2mortal(newSVpvs_share(m))) #define get_metaclass(name) mouse_get_metaclass(aTHX_ name) SV* mouse_call0(pTHX_ SV *const self, SV *const method); SV* mouse_call1(pTHX_ SV *const self, SV *const method, SV* const arg1); int mouse_predicate_call(pTHX_ SV* const self, SV* const method); SV* mouse_get_metaclass(pTHX_ SV* metaclass_name); GV* mouse_stash_fetch(pTHX_ HV* const stash, const char* const name, I32 const namelen, I32 const create); #define stash_fetch(s, n, l, c) mouse_stash_fetch(aTHX_ (s), (n), (l), (c)) #define stash_fetchs(s, n, c) mouse_stash_fetch(aTHX_ (s), STR_WITH_LEN(n), (c)) void mouse_install_sub(pTHX_ GV* const gv, SV* const code_ref); void mouse_must_defined(pTHX_ SV* const value, const char* const name); void mouse_must_ref(pTHX_ SV* const value, const char* const name, svtype const t); #define must_defined(sv, name) mouse_must_defined(aTHX_ sv, name) #define must_ref(sv, name, svt) mouse_must_ref(aTHX_ sv, name, svt) #define MOUSEf_DIE_ON_FAIL 0x01 MAGIC* mouse_mg_find(pTHX_ SV* const sv, const MGVTBL* const vtbl, I32 const flags); /* MOUSE_av_at(av, ix) is the safer version of AvARRAY(av)[ix] if perl is compiled with -DDEBUGGING */ #ifdef DEBUGGING #define MOUSE_av_at(av, ix) mouse_av_at_safe(aTHX_ (av) , (ix)) SV* mouse_av_at_safe(pTHX_ AV* const mi, I32 const ix); #else #define MOUSE_av_at(av, ix) \ (AvARRAY(av)[ix] ? AvARRAY(av)[ix] : &PL_sv_undef) #endif #define MOUSE_mg_obj(mg) ((mg)->mg_obj) #define MOUSE_mg_ptr(mg) ((mg)->mg_ptr) #define MOUSE_mg_len(mg) ((mg)->mg_len) #define MOUSE_mg_flags(mg) ((mg)->mg_private) #define MOUSE_mg_virtual(mg) ((mg)->mg_virtual) #define MOUSE_mg_slot(mg) MOUSE_mg_obj(mg) #define MOUSE_mg_xa(mg) ((AV*)MOUSE_mg_ptr(mg)) /* mouse_instance.xs stuff */ SV* mouse_instance_create (pTHX_ HV* const stash); SV* mouse_instance_clone (pTHX_ SV* const instance); bool mouse_instance_has_slot (pTHX_ SV* const instance, SV* const slot); SV* mouse_instance_get_slot (pTHX_ SV* const instance, SV* const slot); SV* mouse_instance_set_slot (pTHX_ SV* const instance, SV* const slot, SV* const value); SV* mouse_instance_delete_slot(pTHX_ SV* const instance, SV* const slot); void mouse_instance_weaken_slot(pTHX_ SV* const instance, SV* const slot); #define has_slot(self, key) mouse_instance_has_slot(aTHX_ self, key) #define get_slot(self, key) mouse_instance_get_slot(aTHX_ self, key) #define set_slot(self, key, value) mouse_instance_set_slot(aTHX_ self, key, value) #define delete_slot(self, key) mouse_instance_delete_slot(aTHX_ self, key) #define weaken_slot(self, key) mouse_instance_weaken_slot(aTHX_ self, key) #define has_slots(self, key) has_slot(self, sv_2mortal(newSVpvs_share(key))) #define get_slots(self, key) get_slot(self, sv_2mortal(newSVpvs_share(key))) #define set_slots(self, key, value) set_slot(self, sv_2mortal(newSVpvs_share(key)), value) /* mouse_simle_accessor.xs for meta object protocols */ #define INSTALL_SIMPLE_READER(klass, name) \ INSTALL_SIMPLE_READER_WITH_KEY(klass, name, name) #define INSTALL_SIMPLE_READER_WITH_KEY(klass, name, key) \ (void)mouse_simple_accessor_generate(aTHX_ "Mouse::Meta::" #klass "::" \ #name, #key, sizeof(#key)-1, XS_Mouse_simple_reader, NULL, 0) #define INSTALL_CLASS_HOLDER_SV(klass, name, dsv) \ (void)mouse_simple_accessor_generate(aTHX_ "Mouse::Meta::" #klass "::" \ #name, #name, sizeof(#name)-1, XS_Mouse_simple_reader, (dsv), HEf_SVKEY) #define INSTALL_CLASS_HOLDER(klass, name, ds) \ INSTALL_CLASS_HOLDER_SV(klass, name, newSVpvs(ds)) #define INSTALL_SIMPLE_WRITER(klass, name) \ NSTALL_SIMPLE_WRITER_WITH_KEY(klass, name, name) #define INSTALL_SIMPLE_WRITER_WITH_KEY(klass, name, key) \ (void)mouse_simple_accessor_generate(aTHX_ "Mouse::Meta::" #klass "::" \ #name, #key, sizeof(#key)-1, XS_Mouse_simple_writer, NULL, 0) #define INSTALL_SIMPLE_PREDICATE(klass, name) \ INSTALL_SIMPLE_PREDICATE_WITH_KEY(klass, name, name) #define INSTALL_SIMPLE_PREDICATE_WITH_KEY(klass, name, key) \ (void)mouse_simple_accessor_generate(aTHX_ "Mouse::Meta::" #klass "::" \ #name, #key, sizeof(#key)-1, XS_Mouse_simple_predicate, NULL, 0) /* generate inhertiable class accessors for Mouse::Meta::Class */ #define INSTALL_INHERITABLE_CLASS_ACCESSOR(name) \ INSTALL_INHERITABLE_CLASS_ACCESSOR_WITH_KEY(name, name) #define INSTALL_INHERITABLE_CLASS_ACCESSOR_WITH_KEY(name, key) \ (void)mouse_simple_accessor_generate(aTHX_ "Mouse::Meta::Class::" #name,\ #key, sizeof(#key)-1, XS_Mouse_inheritable_class_accessor, NULL, 0) CV* mouse_simple_accessor_generate(pTHX_ const char* const fq_name, const char* const key, I32 const keylen, XSUBADDR_t const accessor_impl, void* const dptr, I32 const dlen); XS(XS_Mouse_simple_reader); XS(XS_Mouse_simple_writer); XS(XS_Mouse_simple_clearer); XS(XS_Mouse_simple_predicate); CV* mouse_accessor_generate(pTHX_ SV* const attr, XSUBADDR_t const accessor_impl); XS(XS_Mouse_accessor); XS(XS_Mouse_reader); XS(XS_Mouse_writer); XS(XS_Mouse_inheritable_class_accessor); /* type constraints */ int mouse_tc_check(pTHX_ SV* const tc, SV* const sv); int mouse_tc_Any (pTHX_ SV*, SV* const sv); int mouse_tc_Bool (pTHX_ SV*, SV* const sv); int mouse_tc_Undef (pTHX_ SV*, SV* const sv); int mouse_tc_Defined (pTHX_ SV*, SV* const sv); int mouse_tc_Value (pTHX_ SV*, SV* const sv); int mouse_tc_Num (pTHX_ SV*, SV* const sv); int mouse_tc_Int (pTHX_ SV*, SV* const sv); int mouse_tc_Str (pTHX_ SV*, SV* const sv); int mouse_tc_ClassName (pTHX_ SV*, SV* const sv); int mouse_tc_RoleName (pTHX_ SV*, SV* const sv); int mouse_tc_Ref (pTHX_ SV*, SV* const sv); int mouse_tc_ScalarRef (pTHX_ SV*, SV* const sv); int mouse_tc_ArrayRef (pTHX_ SV*, SV* const sv); int mouse_tc_HashRef (pTHX_ SV*, SV* const sv); int mouse_tc_CodeRef (pTHX_ SV*, SV* const sv); int mouse_tc_RegexpRef (pTHX_ SV*, SV* const sv); int mouse_tc_GlobRef (pTHX_ SV*, SV* const sv); int mouse_tc_FileHandle(pTHX_ SV*, SV* const sv); int mouse_tc_Object (pTHX_ SV*, SV* const sv); CV* mouse_generate_isa_predicate_for(pTHX_ SV* const klass, const char* const predicate_name); CV* mouse_generate_can_predicate_for(pTHX_ SV* const klass, const char* const predicate_name); int mouse_is_an_instance_of(pTHX_ HV* const stash, SV* const instance); /* Mouse XS Attribute object */ AV* mouse_get_xa(pTHX_ SV* const attr); SV* mouse_xa_apply_type_constraint(pTHX_ AV* const xa, SV* value, U16 const flags); SV* mouse_xa_set_default(pTHX_ AV* const xa, SV* const object); enum mouse_xa_ix_t{ MOUSE_XA_SLOT, /* for constructors, sync to mg_obj */ MOUSE_XA_FLAGS, /* for constructors, sync to mg_private */ MOUSE_XA_ATTRIBUTE, MOUSE_XA_INIT_ARG, MOUSE_XA_TC, MOUSE_XA_TC_CODE, MOUSE_XA_last }; #define MOUSE_xa_slot(m) MOUSE_av_at(m, MOUSE_XA_SLOT) #define MOUSE_xa_flags(m) SvUVX( MOUSE_av_at(m, MOUSE_XA_FLAGS) ) #define MOUSE_xa_attribute(m) MOUSE_av_at(m, MOUSE_XA_ATTRIBUTE) #define MOUSE_xa_init_arg(m) MOUSE_av_at(m, MOUSE_XA_INIT_ARG) #define MOUSE_xa_tc(m) MOUSE_av_at(m, MOUSE_XA_TC) #define MOUSE_xa_tc_code(m) MOUSE_av_at(m, MOUSE_XA_TC_CODE) enum mouse_xa_flags_t{ MOUSEf_ATTR_HAS_TC = 0x0001, MOUSEf_ATTR_HAS_DEFAULT = 0x0002, MOUSEf_ATTR_HAS_BUILDER = 0x0004, MOUSEf_ATTR_HAS_INITIALIZER = 0x0008, /* not used */ MOUSEf_ATTR_HAS_TRIGGER = 0x0010, MOUSEf_ATTR_IS_LAZY = 0x0020, MOUSEf_ATTR_IS_WEAK_REF = 0x0040, MOUSEf_ATTR_IS_REQUIRED = 0x0080, MOUSEf_ATTR_SHOULD_COERCE = 0x0100, MOUSEf_ATTR_SHOULD_AUTO_DEREF = 0x0200, MOUSEf_TC_IS_ARRAYREF = 0x0400, MOUSEf_TC_IS_HASHREF = 0x0800, MOUSEf_OTHER1 = 0x1000, MOUSEf_OTHER2 = 0x2000, MOUSEf_OTHER3 = 0x4000, MOUSEf_OTHER4 = 0x8000, MOUSEf_MOUSE_MASK = 0xFFFF /* not used */ }; /* Mouse::Meta::Class stuff */ HV* mouse_get_namespace(pTHX_ SV* const meta); /* $meta->namespace */ #endif /* !MOUSE_H */ 000-load.t000644000765000024 110612245117717 13603 0ustar00gfxstaff000000000000Mouse-2.1.0/t#!perl -T package Foo; use strict; use warnings; use Test::More tests => 2; require_ok 'Mouse'; require_ok 'Mouse::Role'; no warnings 'uninitialized'; my $xs = !exists( $INC{'Mouse/PurePerl.pm'} ); diag "Testing Mouse/$Mouse::VERSION (", $xs ? 'XS' : 'Pure Perl', ")"; eval { diag "XS state: " . ( Mouse::Util::MOUSE_XS() ? 'true' : 'false' ); }; diag $@ if $@; diag "ENV: " . ( $ENV{PERL_ONLY} ? 'true' : 'false' ); diag ""; diag "Soft dependency versions:"; eval { require Moose }; diag " Class::MOP: $Class::MOP::VERSION"; diag " Moose: $Moose::VERSION"; 002_schwartz_tutorial.t000644000765000024 622712245117717 20562 0ustar00gfxstaff000000000000Mouse-2.1.0/t/000_recipes#!/usr/bin/perl # This adapted from the tutorial here: # http://www.stonehenge.com/merlyn/LinuxMag/col94.html # The Moose is Flying (part 1)' # Using Mouse, instead # use feature ':5.10'; use strict; use warnings; use Test::More; # functions to capture the output of the tutorial our $DUMMY_STDOUT = ""; sub dprint { $DUMMY_STDOUT .= join "", @_ }; sub stdout { my $stdout = $DUMMY_STDOUT; $DUMMY_STDOUT = ""; return $stdout } sub say { ::dprint $_, "\n" for @_ } ###################################################################### # This is the tutorial, as posted by Heikki Lehvaslaiho in Mouse's RT # ticket #42992, except with print and say modified to use the above. package Animal; use Mouse::Role; has 'name' => (is => 'rw'); sub speak { my $self = shift; ::dprint $self->name, " goes ", $self->sound, "\n"; } requires 'sound'; has 'color' => (is => 'rw', default => sub { shift->default_color }); requires 'default_color'; no Mouse::Role; 1; ## Cow.pm: package Cow; use Mouse; with 'Animal'; sub default_color { 'spotted' } sub sound { 'moooooo' } no Mouse; 1; ## Horse.pm: package Horse; use Mouse; with 'Animal'; sub default_color { 'brown' } sub sound { 'neigh' } no Mouse; 1; ## Sheep.pm: package Sheep; use Mouse; with 'Animal'; sub default_color { 'black' } sub sound { 'baaaah' } no Mouse; 1; package MouseA; use Mouse; with 'Animal'; sub default_color { 'white' } sub sound { 'squeak' } after 'speak' => sub { ::dprint "[but you can barely hear it!]\n"; }; before 'speak' => sub { ::dprint "[Ahem]\n"; }; no Mouse; 1; package Racer; use Mouse::Role; has $_ => (is => 'rw', default => 0) foreach qw(wins places shows losses); sub won { my $self = shift; $self->wins($self->wins + 1) } sub placed { my $self = shift; $self->places($self->places + 1) } sub showed { my $self = shift; $self->shows($self->shows + 1) } sub lost { my $self = shift; $self->losses($self->losses + 1) } sub standings { my $self = shift; join ", ", map { $self->$_ . " $_" } qw(wins places shows losses); } no Mouse::Role; 1; # To create the race horse, we just mix a horse with a racer: package RaceHorse; use Mouse; extends 'Horse'; with 'Racer'; no Mouse; 1; ###################################################################### # Now the tests package main; plan tests => 5; #use Horse; my $talking = Horse->new(name => 'Mr. Ed'); say $talking->name; # prints Mr. Ed is stdout, "Mr. Ed\n"; $talking->color("grey"); # sets the color $talking->speak; # says "Mr. Ed goes neigh" is stdout, <new(color => 'white', name => 'Baab'); $baab->speak; # prints "Baab goes baaaah" is stdout, <new(name => 'Mickey'); $mickey->speak; is stdout, <new(name => 'Seattle Slew'); $s->won; $s->won; $s->won; $s->placed; $s->lost; # run some races ::dprint $s->standings, "\n"; # 3 wins, 1 places, 0 shows, 1 losses is stdout, < 10; { package Human; use Mouse; use Mouse::Util::TypeConstraints; subtype 'Gender' => as 'Str' => where { $_ =~ m{^[mf]$}s }; has 'gender' => ( is => 'ro', isa => 'Gender', required => 1 ); has 'mother' => ( is => 'ro', isa => 'Human' ); has 'father' => ( is => 'ro', isa => 'Human' ); use overload '+' => \&_overload_add, fallback => 1; sub _overload_add { my ( $one, $two ) = @_; die('Only male and female humans may create children') if ( $one->gender() eq $two->gender() ); my ( $mother, $father ) = ( $one->gender eq 'f' ? ( $one, $two ) : ( $two, $one ) ); my $gender = 'f'; $gender = 'm' if ( rand() >= 0.5 ); return Human->new( gender => $gender, eye_color => ( $one->eye_color() + $two->eye_color() ), mother => $mother, father => $father, ); } # use List::MoreUtils 'zip' # code taken from List::MoreUtils sub zip (\@\@;\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@) { my $max = -1; $max < $#$_ && ( $max = $#$_ ) for @_; map { my $ix = $_; map $_->[$ix], @_; } 0 .. $max; } coerce 'Human::EyeColor' => from 'ArrayRef' => via { my @genes = qw( bey2_1 bey2_2 gey_1 gey_2 ); return Human::EyeColor->new( zip( @genes, @{$_} ) ); }; has 'eye_color' => ( is => 'ro', isa => 'Human::EyeColor', coerce => 1, required => 1, ); } { package Human::Gene::bey2; use Mouse; use Mouse::Util::TypeConstraints; type 'bey2_color' => where { $_ =~ m{^(?:brown|blue)$} }; has 'color' => ( is => 'ro', isa => 'bey2_color' ); } { package Human::Gene::gey; use Mouse; use Mouse::Util::TypeConstraints; type 'gey_color' => where { $_ =~ m{^(?:green|blue)$} }; has 'color' => ( is => 'ro', isa => 'gey_color' ); } { package Human::EyeColor; use Mouse; use Mouse::Util::TypeConstraints; coerce 'Human::Gene::bey2' => from 'Str' => via { Human::Gene::bey2->new( color => $_ ) }; coerce 'Human::Gene::gey' => from 'Str' => via { Human::Gene::gey->new( color => $_ ) }; has [qw( bey2_1 bey2_2 )] => ( is => 'ro', isa => 'Human::Gene::bey2', coerce => 1 ); has [qw( gey_1 gey_2 )] => ( is => 'ro', isa => 'Human::Gene::gey', coerce => 1 ); sub color { my ($self) = @_; return 'brown' if ( $self->bey2_1->color() eq 'brown' or $self->bey2_2->color() eq 'brown' ); return 'green' if ( $self->gey_1->color() eq 'green' or $self->gey_2->color() eq 'green' ); return 'blue'; } use overload '""' => \&color, fallback => 1; use overload '+' => \&_overload_add, fallback => 1; sub _overload_add { my ( $one, $two ) = @_; my $one_bey2 = 'bey2_' . _rand2(); my $two_bey2 = 'bey2_' . _rand2(); my $one_gey = 'gey_' . _rand2(); my $two_gey = 'gey_' . _rand2(); return Human::EyeColor->new( bey2_1 => $one->$one_bey2->color(), bey2_2 => $two->$two_bey2->color(), gey_1 => $one->$one_gey->color(), gey_2 => $two->$two_gey->color(), ); } sub _rand2 { return 1 + int( rand(2) ); } } my $gene_color_sets = [ [ qw( blue blue blue blue ) => 'blue' ], [ qw( blue blue green blue ) => 'green' ], [ qw( blue blue blue green ) => 'green' ], [ qw( blue blue green green ) => 'green' ], [ qw( brown blue blue blue ) => 'brown' ], [ qw( brown brown green green ) => 'brown' ], [ qw( blue brown green blue ) => 'brown' ], ]; foreach my $set (@$gene_color_sets) { my $expected_color = pop(@$set); my $person = Human->new( gender => 'f', eye_color => $set, ); is( $person->eye_color(), $expected_color, 'gene combination ' . join( ',', @$set ) . ' produces ' . $expected_color . ' eye color', ); } my $parent_sets = [ [ [qw( blue blue blue blue )], [qw( blue blue blue blue )] => 'blue' ], [ [qw( blue blue blue blue )], [qw( brown brown green blue )] => 'brown' ], [ [qw( blue blue green green )], [qw( blue blue green green )] => 'green' ], ]; foreach my $set (@$parent_sets) { my $expected_color = pop(@$set); my $mother = Human->new( gender => 'f', eye_color => shift(@$set), ); my $father = Human->new( gender => 'm', eye_color => shift(@$set), ); my $child = $mother + $father; is( $child->eye_color(), $expected_color, 'mother ' . $mother->eye_color() . ' + father ' . $father->eye_color() . ' = child ' . $expected_color, ); } # Hmm, not sure how to test for random selection of genes since # I could theoretically run an infinite number of iterations and # never find proof that a child has inherited a particular gene. # AUTHOR: Aran Clary Deltac moose_cookbook_basics_recipe1.t000644000765000024 1202412245117717 22365 0ustar00gfxstaff000000000000Mouse-2.1.0/t/000_recipes#!/usr/bin/perl -w use strict; use Test::More 'no_plan'; use Test::Exception; $| = 1; # =begin testing SETUP { package Point; use Mouse; 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 Mouse; 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, 'Mouse::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' ); dies_ok { $point->y('Foo'); } '... cannot assign a non-Int to y'; dies_ok { Point->new(); } '... 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 lives_ok { Point->new( x => 0, y => 0 ); } '... can assign a 0 to x and y'; dies_ok { Point->new( x => 10, y => 'Foo' ); } '... cannot assign a non-Int to y'; dies_ok { Point->new( x => 'Foo', y => 10 ); } '... 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, 'Mouse::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' ); dies_ok { Point3D->new( x => 10, y => 'Foo', z => 3 ); } '... cannot assign a non-Int to y'; dies_ok { Point3D->new( x => 'Foo', y => 10, z => 3 ); } '... cannot assign a non-Int to x'; dies_ok { Point3D->new( x => 0, y => 10, z => 'Bar' ); } '... cannot assign a non-Int to z'; dies_ok { Point3D->new( x => 10, y => 3 ); } '... z is a required attribute for Point3D'; # test some class introspection can_ok( 'Point', 'meta' ); isa_ok( Point->meta, 'Mouse::Meta::Class' ); can_ok( 'Point3D', 'meta' ); isa_ok( Point3D->meta, 'Mouse::Meta::Class' ); isnt( Point->meta, Point3D->meta, '... they are different metaclasses as well' ); # poke at Point is_deeply( [ Point->meta->superclasses ], ['Mouse::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, 'Mouse::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, 'Mouse::Meta::TypeConstraint' ); is( $attr->type_constraint->name, 'Int', '... Attribute ' . $attr_name . ' has an Int type constraint' ); } } 1; moose_cookbook_basics_recipe2.t000644000765000024 675212245117717 22361 0ustar00gfxstaff000000000000Mouse-2.1.0/t/000_recipes#!/usr/bin/perl -w use strict; use Test::More 'no_plan'; use Test::Exception; $| = 1; # =begin testing SETUP { package BankAccount; use Mouse; has 'balance' => ( isa => 'Int', is => 'rw', default => 0 ); sub deposit { my ( $self, $amount ) = @_; $self->balance( $self->balance + $amount ); } sub withdraw { my ( $self, $amount ) = @_; my $current_balance = $self->balance(); ( $current_balance >= $amount ) || confess "Account overdrawn"; $self->balance( $current_balance - $amount ); } package CheckingAccount; use Mouse; extends 'BankAccount'; has 'overdraft_account' => ( isa => 'BankAccount', is => 'rw' ); before 'withdraw' => sub { my ( $self, $amount ) = @_; my $overdraft_amount = $amount - $self->balance(); if ( $self->overdraft_account && $overdraft_amount > 0 ) { $self->overdraft_account->withdraw($overdraft_amount); $self->deposit($overdraft_amount); } }; } # =begin testing { my $savings_account; { $savings_account = BankAccount->new( balance => 250 ); isa_ok( $savings_account, 'BankAccount' ); is( $savings_account->balance, 250, '... got the right savings balance' ); lives_ok { $savings_account->withdraw(50); } '... withdrew from savings successfully'; is( $savings_account->balance, 200, '... got the right savings balance after withdrawl' ); $savings_account->deposit(150); is( $savings_account->balance, 350, '... got the right savings balance after deposit' ); } { my $checking_account = CheckingAccount->new( balance => 100, overdraft_account => $savings_account ); isa_ok( $checking_account, 'CheckingAccount' ); isa_ok( $checking_account, 'BankAccount' ); is( $checking_account->overdraft_account, $savings_account, '... got the right overdraft account' ); is( $checking_account->balance, 100, '... got the right checkings balance' ); lives_ok { $checking_account->withdraw(50); } '... withdrew from checking successfully'; is( $checking_account->balance, 50, '... got the right checkings balance after withdrawl' ); is( $savings_account->balance, 350, '... got the right savings balance after checking withdrawl (no overdraft)' ); lives_ok { $checking_account->withdraw(200); } '... withdrew from checking successfully'; is( $checking_account->balance, 0, '... got the right checkings balance after withdrawl' ); is( $savings_account->balance, 200, '... got the right savings balance after overdraft withdrawl' ); } { my $checking_account = CheckingAccount->new( balance => 100 # no overdraft account ); isa_ok( $checking_account, 'CheckingAccount' ); isa_ok( $checking_account, 'BankAccount' ); is( $checking_account->overdraft_account, undef, '... no overdraft account' ); is( $checking_account->balance, 100, '... got the right checkings balance' ); lives_ok { $checking_account->withdraw(50); } '... withdrew from checking successfully'; is( $checking_account->balance, 50, '... got the right checkings balance after withdrawl' ); dies_ok { $checking_account->withdraw(200); } '... withdrawl failed due to attempted overdraft'; is( $checking_account->balance, 50, '... got the right checkings balance after withdrawl failure' ); } } 1; moose_cookbook_basics_recipe3.t000644000765000024 727612245117717 22364 0ustar00gfxstaff000000000000Mouse-2.1.0/t/000_recipes#!/usr/bin/perl -w use strict; use Test::More 'no_plan'; use Test::Exception; $| = 1; # =begin testing SETUP { package BinaryTree; use Mouse; 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'); lives_ok { $left->node('left') } '... 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'); lives_ok { $right->node('right') } '... 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'); lives_ok { $left->right($left_right) } '... 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 dies_ok { $left_right->right($left_left) } '... cant assign a node which already has a parent'; } 1; moose_cookbook_basics_recipe4.t000644000765000024 2206112245117717 22372 0ustar00gfxstaff000000000000Mouse-2.1.0/t/000_recipes#!/usr/bin/perl -w use strict; use Test::More; BEGIN{ eval 'use Regexp::Common; use Locale::US;'; if ($@) { plan skip_all => 'Regexp::Common & Locale::US required for this test'; } else{ plan 'no_plan'; } } use Test::Exception; $| = 1; # =begin testing SETUP BEGIN { eval 'use Regexp::Common; use Locale::US;'; if ($@) { plan skip_all => 'Regexp::Common & Locale::US required for this test'; } } # =begin testing SETUP { package Address; use Mouse; use Mouse::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 Mouse; use Mouse::Util::TypeConstraints; has 'name' => ( is => 'rw', isa => 'Str', required => 1 ); has 'address' => ( is => 'rw', isa => 'Address' ); has 'employees' => ( is => 'rw', isa => 'ArrayRef[Employee]' ); sub BUILD { my ( $self, $params ) = @_; if ( @{ $self->employees || [] } ) { foreach my $employee ( @{ $self->employees } ) { $employee->employer($self); } } } after 'employees' => sub { my ( $self, $employees ) = @_; if ($employees) { foreach my $employee ( @{$employees} ) { $employee->employer($self); } } }; package Person; use Mouse; 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 Mouse; 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; lives_ok { $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' ) ), ] } ); } '... 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 dies_ok { Address->new( street => {} ),; } '... we die correctly with bad args'; dies_ok { Address->new( city => {} ),; } '... we die correctly with bad args'; dies_ok { Address->new( state => 'British Columbia' ),; } '... we die correctly with bad args'; lives_ok { Address->new( state => 'Connecticut' ),; } '... we live correctly with good args'; dies_ok { Address->new( zip_code => 'AF5J6$' ),; } '... we die correctly with bad args'; lives_ok { Address->new( zip_code => '06443' ),; } '... we live correctly with good args'; dies_ok { Company->new(),; } '... we die correctly without good args'; lives_ok { Company->new( name => 'Foo' ),; } '... we live correctly without good args'; dies_ok { Company->new( name => 'Foo', employees => [ Person->new ] ),; } '... we die correctly with good args'; lives_ok { Company->new( name => 'Foo', employees => [] ),; } '... we live correctly with good args'; } 1; moose_cookbook_basics_recipe5.t000644000765000024 627512245117717 22364 0ustar00gfxstaff000000000000Mouse-2.1.0/t/000_recipes#!/usr/bin/perl -w use strict; use Test::More 'no_plan'; use Test::Exception; $| = 1; # =begin testing SETUP BEGIN { eval 'use HTTP::Headers; use Params::Coerce; use URI;'; if ($@) { diag 'HTTP::Headers, Params::Coerce & URI required for this test'; ok(1); exit 0; } } # =begin testing SETUP { package Request; use Mouse; use Mouse::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' ); dies_ok { $r->headers('Foo'); } '... dies when it gets bad params'; } { is( $r->protocol, undef, '... got nothing by default' ); lives_ok { $r->protocol('HTTP/1.0'); } '... set the protocol correctly'; is( $r->protocol, 'HTTP/1.0', '... got nothing by default' ); dies_ok { $r->protocol('http/1.0'); } '... 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; moose_cookbook_basics_recipe6.t000644000765000024 271512245117717 22360 0ustar00gfxstaff000000000000Mouse-2.1.0/t/000_recipes#!/usr/bin/perl -w use strict; use Test::More 'no_plan'; use Test::Exception; $| = 1; # =begin testing SETUP { package Document::Page; use Mouse; has 'body' => ( is => 'rw', isa => 'Str', default => sub {''} ); sub create { my $self = shift; $self->open_page; inner(); $self->close_page; } sub append_body { my ( $self, $appendage ) = @_; $self->body( $self->body . $appendage ); } sub open_page { (shift)->append_body('') } sub close_page { (shift)->append_body('') } package Document::PageWithHeadersAndFooters; use Mouse; extends 'Document::Page'; augment 'create' => sub { my $self = shift; $self->create_header; inner(); $self->create_footer; }; sub create_header { (shift)->append_body('
') } sub create_footer { (shift)->append_body('