NEXT
+ [API CHANGES]
+
+ * Roles now have their own default attribute metaclass to use during
+ application to a class, rather than just using the class's
+ attribute_metaclass. This is also overridable via ::MetaRole, with the
+ applied_attribute key in the role_metaroles hashref (doy).
+
+ * The internal code used to generate inlined methods (accessor, constructor,
+ etc.) has been massively rewritten. MooseX modules that do inlining will
+ almost certainly need to be updated as well.
+
+ [ENHANCEMENTS]
+
+ * We now load the roles needed for native delegations only as needed. This
+ speeds up the compilation time for Moose itself. (doy)
+
[BUG FIXES]
* When using native delegations, if an array or hash ref member failed a
both start with an underscore. The C<builder> method I<always> starts
with an underscore.
-You can read more about C<lazy_build> in L<Moose::Manual::Attributes>
+You can read more about C<lazy_build> in L<Moose::Meta::Attribute>
=head1 CONCLUSION
}
$msg .= " - size is now $size";
- warn $msg.
+ warn $msg;
}
The trigger is called I<after> an attribute's value is set. It is
=back
-=item Core Committers - people reviewing and merging a branch
-
-These people have worked with the Moose codebase for a while.
-
-They've been responsible for large features or branches and can help review
-your changes and apply them to the master branch using the basic
-L</APPROVAL WORKFLOW>.
-
-They are also fairly well versed in Git, in order to merge the branches with
-no mistakes (especially when the merge fails), and to provide advice to
-contributors.
-
=item Cabal - people who can release moose
These people are the ones who have co-maint on Moose itself and can create a
release. They're listed under L<Moose/CABAL> in the Moose documentation. They
-merge from Master to Stable.
+are responsible for reviewing branches, and are the only people who are allowed
+to push to stable branches.
+
+Cabal members are listed in L<Moose> and can often be found on irc in the
+L<irc://irc.perl.org/#moose-dev> channel.
=back
=over
-=item Stable (refs/heads/stable)
+=item stable/*
+
+The branch from which releases are cut. When making a new major release, the
+release manager makes a new C<stable/$version> branch at the current position
+of C<master>. For minor releases, patches will be committed to C<master>, and
+backported (cherry-picked) to the appropriate stable branch as needed. The
+C<stable> branch is only updated by someone from the Cabal during a release.
-The branch from which releases are cut. When making a new release, the
-release manager merges from master to stable. The stable branch is only
-updated by someone from the Cabal during a release.
+=item master
-=item Master (refs/heads/master)
+The main development branch. All new code should be written against this
+branch. This branch contains code that has been reviewed, and will be included
+in the next major release. Commits which are judged to not break backwards
+compatibility may be backported into C<stable> to be included in the next minor
+release.
-The branch for new development. This branch is merged into and branched from.
+=item rfc/*
-=item Branches (refs/heads/*)
+Topic branches that are completed and waiting on review. A Cabal member will
+look over branches in this namespace, and either merge them to C<master> if
+they are acceptable, or move them back to a different namespace otherwise.
-Large community branches for big development "projects".
+=item topic/*
-=item Topics (refs/heads/topic/*)
+Small personal branches that are still in progress. They can be freely rebased.
+They contain targeted features that may span a handful of commits. Any change
+or bugfix should be created in a topic branch.
-Small personal branches that have been published for review, but can get
-freely rebased. Targeted features that may span a handful of commits.
+=item attic/*
-Any change or bugfix should be created in a topic branch.
+Branches which have been reviewed, and rejected. They remain in the repository
+in case we later change our mind, or in case parts of them are still useful.
+
+=item abandoned/*
+
+Topic branches which have had no activity for a long period of time will be
+moved here, to keep the main areas clean.
=back
+Larger, longer term branches can also be created in the root namespace (i.e.
+at the same level as master and stable). This may be appropriate if multiple
+people are intending to work on the branch. These branches should not be
+rebased without checking with other developers first.
+
=head1 STANDARD WORKFLOW
# update your copy of master
git pull --rebase
# create a new topic branch
- git checkout -b topic/my-feature origin/master
+ git checkout -b topic/my-feature
# hack, commit, feel free to break fast forward
- git commit --amend # allowed
- git rebase --interactive # allowed
- git push --force origin topic/my_feature # allowed
-
-Then ask for a review/approval (see L</APPROVAL WORKFLOW>), and merge
-to master. If it merges cleanly and nobody has any objections, then it
-can be pushed to master.
-
-If it doesn't merge as a fast forward, the author of the branch needs to run
+ git commit --amend # allowed
+ git rebase --interactive # allowed
+ git push --force # allowed
+ # keep the branch rebased on top of master, for easy reviewing
git remote update
- git rebase origin/master # or merge
+ git rebase origin/master
+ git push --force
-and bring the branch up to date, so that it can be merged as a fast forward
-into master.
-
-No actual merging (as in a human resolving conflicts) should be done when
-merging into master, only from master into other branches.
-
-=head2 Preparing a topic branch
-
-Before a merge, a topic branch can be cleaned up by the author.
-
-This can be done using interactive rebase to combine commits, etc, or even
-C<git merge --squash> to make the whole topic into a single commit.
-
-Structuring changes like this makes it easier to apply git revert at a later
-date, and encourages a clean and descriptive history that documents what the
-author was trying to do, without the various hangups that happened while they
-were trying to do it (commits like "oops forgot that file" are not only
-unnecessary noise, they also make running things like git bisect or git revert
-harder).
+ # when finished, move the branch to the rfc/ namespace
+ git branch -m rfc/my-feature
+ git push
+ git push origin :topic/my-feature
-However, by far the biggest benefit is that the number of commits that go into
-master is eventually reduced, and they are simple and coherent, making it much
-easier for people maintaining branches to stay up to date.
+When your branch is completed, make sure it has been moved to the C<rfc/>
+namespace and is rebased on top of master, and ask for review/approval (see
+L</APPROVAL WORKFLOW>). If it is approved, the reviewer will merge it into
+C<master>.
-All large changes should be documented in L<Moose::Manual::Delta>.
+No actual merging (as in a human resolving conflicts) should be done when
+merging into C<master>, only from C<master> into other branches.
=head1 APPROVAL WORKFLOW
the master branch.
It should be noted that if you want your specific branch to be approved, it is
-B<your> responsibility to follow this process and advocate for your branch.
-The preferred way is to send a request to the mailing list for review/approval,
+B<your> responsibility to follow this process and advocate for your branch. The
+preferred way is to send a request to the mailing list for review/approval;
this allows us to better keep track of the branches awaiting approval and those
which have been approved.
=item Small bug fixes, doc patches and additional passing tests.
These items don't really require approval beyond one of the core contributors
-just doing a simple review.
+just doing a simple review. For especially simple patches (doc patches
+especially), committing directly to master is fine.
=item Larger bug fixes, doc additions and TODO or failing tests.
TODO tests are basically feature requests, see our L</NEW FEATURES> section
for more information on that. If your feature needs core support, create a
-topic/ branch using the L</STANDARD WORKFLOW> and start hacking away.
+C<topic/> branch using the L</STANDARD WORKFLOW> and start hacking away.
Failing tests are basically bug reports. You should find a core contributor
and/or cabal member to see if it is a real bug, then submit the bug and your
=item Backwards incompatible changes.
-Anything that breaks backwards compatibility must be discussed by the cabal
-and agreed to by a majority of the members.
+Anything that breaks backwards compatibility must be discussed by the
+cabal. Backwards incompatbible changes should not be merged to master if there
+are strong objections for any cabal members.
We have a policy for what we see as sane L</BACKWARDS COMPATIBILITY> for
Moose. If your changes break back-compat, you must be ready to discuss and
=head1 RELEASE WORKFLOW
+ # major releases (including trial releases)
git checkout master
+
+ # minor releases
+ git checkout stable
+
# edit for final version bumping, changelogging, etc
# prepare release (test suite etc)
perl-reversion -bump
make manifest
git commit
- git checkout stable
- git merge master # must be a fast forward
- git push both
+ git branch stable/2.XXYY # only for non-trial major releases
shipit # does not ship the tarball, but does everything else
- cpan-upload ~/shipit-dist/Moose-X.YZ.tar.gz
-Development releases are made without merging into the stable branch.
+ # non-trial releases
+ cpan-upload ~/shipit-dist/Moose-2.XXYY.tar.gz
+
+ # trial releases
+ cd ~/shipit-dist
+ mv Moose-2.XXYY.tar.gz Moose-2.XXYY-TRIAL.tar.gz
+ cpan-upload Moose-2.XXYY-TRIAL.tar.gz
=head2 Release How-To
=head1 EMERGENCY BUG WORKFLOW (for immediate release)
-Anyone can create the necessary fix by branching off of the stable branch:
+The stable branch exists for easily making bug fix releases.
git remote update
- git checkout -b topic/my-emergency-fix origin/stable
+ git checkout -b topic/my-emergency-fix origin/master
# hack
git commit
-Then a cabal member merges into stable:
+Then a cabal member merges into C<master>, and backports the change into
+C<stable>:
- git checkout stable
+ git checkout master
git merge topic/my-emergency-fix
git push
+ git checkout stable
+ git cherry-pick -x master
+ git push
# release
- git checkout master
- git merge stable
=head1 PROJECT WORKFLOW
(unfortunately Git will not allow C<my-project/foo> as a branch name if
C<my-project> is a valid ref).
-=head1 THE "PU" BRANCH
-
-To make things easier for longer lived branches (whether topics or projects),
-the 'pu' branch is basically what happens if you merge all of the branches and
-topics together with master.
-
-We can update this as necessary (e.g. on a weekly basis if there is merit),
-notifying the authors of the respective branches if their branches did not merge
-(and why).
-
-To update 'pu':
-
- git checkout pu
- git remote update
- git reset --hard origin/master
- git merge @all_the_branches
-
-If the merge is clean, 'pu' is updated with C<push --force>.
-
-If the merge is not clean, the offending branch is removed from
-C<@all_the_branches>, with a small note of the conflict, and we try again.
-
-The authors of the failed branches should be told to try to merge their branch
-into 'pu', to see how their branch interacts with other branches.
-
-'pu' is probably broken most of the time, but lets us know how the different
-branches interact.
-
=head1 BRANCH ARCHIVAL
Merged branches should be deleted.
-Failed branches may be kept, but consider moving to refs/attic/ (e.g.
-http://danns.co.uk/node/295) to keep git branch -l current.
+Failed branches may be kept, but should be moved to C<attic/> to differentiate
+them from in-progress topic branches.
Branches that have not been worked on for a long time will be moved to
-refs/abandoned/ periodically, but feel free to move the branch back to
-refs/topic/ if you want to start working on it again.
+C<abandoned/> periodically, but feel free to move the branch back to C<topic/>
+if you want to start working on it again.
=head1 TESTS, TESTS, TESTS
way, please add some comments either near the code in question or in
the test so that others know.
-We also greatly appreciate documentation to go with your changes, and
-an entry in the Changes file. Make sure to give yourself credit!
+We also greatly appreciate documentation to go with your changes, and an entry
+in the Changes file. Make sure to give yourself credit! Major changes or new
+user-facing features should also be documented in L<Moose::Manual::Delta>.
+
+=head1 DOCS, DOCS, DOCS
+
+Any user-facing changes must be accompanied by documentation. If you're not
+comfortable writing docs yourself, you might be able to convince another Moose
+dev to help you.
+
+Our goal is to make sure that all features are documented. Undocumented
+features are not considered part of the API when it comes to determining
+whether a change is backwards compatible.
=head1 BACKWARDS COMPATIBILITY
afraid of change and will do our best to keep it as painless as
possible for the end user.
-The rule is that if you do something that is not backwards compatible, you
-B<must> do I<at least> one deprecation cycle (more if it is larger change).
-For really larger or radical changes dev releases may be needed as well (the
-Cabal will decide on this on a case-per-case basis).
-
-Our policy with deprecation is that each deprecation should go through several
-stages. First, we simply add a deprecation notice the documentation in
-F<Changes> and L<Moose::Manual::Delta>. In a future release, we then make the
-deprecated feature warn loudly and often so that users will have time to fix
-their usages. Finally, the feature is removed in a later release.
+Our policy for handling backwards compatibility is documented in more detail in
+L<Moose::Manual::Support>.
All backwards incompatible changes B<must> be documented in
L<Moose::Manual::Delta>. Make sure to document any useful tips or workarounds
Yuval (nothingmuch) Kogman
+Jesse Luehrs E<lt>doy at tozt dot netE<gt>
+
=head1 COPYRIGHT AND LICENSE
Copyright 2009 by Infinity Interactive, Inc.
it documented here, or think we missed an important feature, please
send us a patch.
+=head1 NEXT
+
+=over 4
+
+=item Roles have their own default attribute metaclass
+
+Previously, when a role was applied to a class, it would use the attribute
+metaclass defined in the class when copying over the attributes in the role.
+This was wrong, because for instance, using L<MooseX::FollowPBP> in the class
+would end up renaming all of the accessors generated by the role, some of which
+may be being called in the role, causing it to break. Roles now keep track of
+their own attribute metaclass to use by default when being applied to a class
+(defaulting to Moose::Meta::Attribute). This is modifiable using
+L<Moose::Util::MetaRole> by passing the C<applied_attribute> key to the
+C<role_metaroles> option, as in:
+
+ Moose::Util::MetaRole::apply_metaroles(
+ for => __PACKAGE__,
+ class_metaroles => {
+ attribute => ['My::Meta::Role::Attribute'],
+ },
+ role_metaroles => {
+ applied_attribute => ['My::Meta::Role::Attribute'],
+ },
+ );
+
+=back
+
=head1 1.16
=over 4
Moose::Manual::Support - Policies regarding support, releases, and
compatibility.
+=head1 SUPPORT POLICY
+
+There are two principles to Moose's policy of supported behavior.
+
+=over 4
+
+=item 1.
+
+Moose favors correctness over everything.
+
+=item 2.
+
+Moose supports documented and tested behavior, not accidental behavior or side
+effects.
+
+=back
+
+If a behavior has never been documented or tested, the behavior is
+I<officially> undefined. Relying upon undocumented and untested behavior is
+done at your own risk.
+
+If a behavior is documented or tested but found to be incorrect later, the
+behavior will go through a deprecation period. During the deprecation period,
+use of that feature will cause a warning. Eventually, the deprecated feature
+will be removed.
+
=head1 RELEASE SCHEDULE
-Moose uses the release early, release often philosophy. Moose is not
-released on a schedule. Releases happen as new features and bug fixes
-are required.
+Moose is on a system of weekly minor releases and quarterly major releases. A
+minor release is defined as one that makes every attempt to preserve backwards
+compatibility. Currently this means that we did not introduce any new
+dependency conflicts, and that we did not make any changes to documented,
+tested behavior. A minor release can include new features and bug fixes.
-Moose has historically been released fairly often, and most releases include
-just a few features or bug fixes.
+Major releases may be backwards incompatible. Moose prioritizes
+correctness over backwards compatibility or performance; see the L<Deprecation
+Policy> to understand how backwards incompatible changes are announced.
+
+Before a major release, a series of development releases will be made so that
+users can test the upcoming major release before it is distributed to CPAN. It
+is in the best interests of everyone involved if these releases are tested as
+widely as possible.
=head1 DEPRECATION POLICY
Moose has always prioritized correctness over performance and backwards
compatibility.
-Major deprecations or API changes are first documented in the Changes
-file as well as in L<Moose::Manual::Delta>.
+Major deprecations or API changes are documented in the Changes file as well
+as in L<Moose::Manual::Delta>. The Moose developers will also make an effort
+to warn users of upcoming deprecations and breakage through the Moose blog
+(http://blog.moose.perl.org).
-Moose then attempts to warn for deprecated features and API changes for
-a reasonable number of releases before breaking any tested API.
+Deprecated APIs will be preserved for at least one year I<after the major
+release which deprecates that API>. Deprecated APIs will only be removed in a
+major release.
-Moose will also warn during installation if the version being installed
-will break a known installed dependency. Unfortunately due to the nature
+Moose will also warn during installation if the version of Moose being
+installed will break an installed dependency. Unfortunately, due to the nature
of the Perl install process these warnings may be easy to miss.
=head1 BACKWARDS COMPATIBILITY
=head1 VERSION NUMBERS
-Moose's version numbers are monotonically incrementing two decimal
-values. The version numbers in Moose are I<not> semantic. This means
-that version 1.00 will be the hundredth release, nothing more.
+Moose version numbers consist of three parts, in the form X.YYZZ. The X is the
+"special magic number" that only gets changed for really big changes. Think of
+this as being like the "5" in Perl 5.12.1.
+
+The YY portion is the major version number. Moose uses even numbers for stable
+releases, and odd numbers for trial releases. The ZZ is the minor version, and
+it simply increases monotonically. It starts at "00" each time a new major
+version is released.
+
+Semantically, this means that any two releases which share a major version
+should be API-compatible with each other. In other words, 2.0200, 2.0201, and
+2.0274 are all API-compatible.
-Occasionally, we will release a test release with a version like
-0.90_03. These versions may be less stable than non-test releases, and exist
-so that developers can test potentially code-breaking changes. By default, the
-CPAN client will not install a distribution which has an underscore in its
-version.
+Prior to version 2.0, Moose version numbers were monotonically incrementing
+two decimal values (0.01, 0.02, ... 1.11, 1.12, etc.).
Moose was declared production ready at version 0.18 (via L<<
http://www.perlmonks.org/?node_id=608144 >>).
goto $handler;
}
+sub _inline_throw_error {
+ my ( $self, $msg, $args ) = @_;
+ "\$meta->throw_error($msg" . ($args ? ", $args" : "") . ")"; # FIXME makes deparsing *REALLY* hard
+}
+
sub new {
my ($class, $name, %options) = @_;
$class->_process_options($name, \%options) unless $options{__hack_no_process_options}; # used from clone()... YECHKKK FIXME ICKY YUCK GROSS
## Slot management
-# FIXME:
-# this duplicates too much code from
-# Class::MOP::Attribute, we need to
-# refactor these bits eventually.
-# - SL
-sub _set_initial_slot_value {
- my ($self, $meta_instance, $instance, $value) = @_;
-
- my $slot_name = $self->name;
-
- return $meta_instance->set_slot_value($instance, $slot_name, $value)
- unless $self->has_initializer;
-
- my $callback = sub {
- my $val = $self->_coerce_and_verify( shift, $instance );;
-
- $meta_instance->set_slot_value($instance, $slot_name, $val);
+sub _make_initializer_writer_callback {
+ my $self = shift;
+ my ($meta_instance, $instance, $slot_name) = @_;
+ my $old_callback = $self->SUPER::_make_initializer_writer_callback(@_);
+ return sub {
+ $old_callback->($self->_coerce_and_verify($_[0], $instance));
};
-
- my $initializer = $self->initializer;
-
- # most things will just want to set a value, so make it first arg
- $instance->$initializer($value, $callback, $self);
}
sub set_value {
}
}
+sub _inline_set_value {
+ my $self = shift;
+ my ($instance, $value, $tc, $tc_obj, $for_constructor) = @_;
+
+ my $old = '@old';
+ my $copy = '$val';
+ $tc ||= '$type_constraint';
+ $tc_obj ||= '$type_constraint_obj';
+
+ my @code;
+ if ($self->_writer_value_needs_copy) {
+ push @code, $self->_inline_copy_value($value, $copy);
+ $value = $copy;
+ }
+
+ # constructors already handle required checks
+ push @code, $self->_inline_check_required
+ unless $for_constructor;
+
+ push @code, $self->_inline_tc_code($value, $tc, $tc_obj);
+
+ # constructors do triggers all at once at the end
+ push @code, $self->_inline_get_old_value_for_trigger($instance, $old)
+ unless $for_constructor;
+
+ push @code, (
+ $self->SUPER::_inline_set_value($instance, $value),
+ $self->_inline_weaken_value($instance, $value),
+ );
+
+ # constructors do triggers all at once at the end
+ push @code, $self->_inline_trigger($instance, $value, $old)
+ unless $for_constructor;
+
+ return @code;
+}
+
+sub _writer_value_needs_copy {
+ my $self = shift;
+ return $self->should_coerce;
+}
+
+sub _inline_copy_value {
+ my $self = shift;
+ my ($value, $copy) = @_;
+
+ return 'my ' . $copy . ' = ' . $value . ';'
+}
+
+sub _inline_check_required {
+ my $self = shift;
+
+ return unless $self->is_required;
+
+ my $attr_name = quotemeta($self->name);
+
+ return (
+ 'if (@_ < 2) {',
+ $self->_inline_throw_error(
+ '"Attribute (' . $attr_name . ') is required, so cannot '
+ . 'be set to undef"' # defined $_[1] is not good enough
+ ) . ';',
+ '}',
+ );
+}
+
+sub _inline_tc_code {
+ my $self = shift;
+ return (
+ $self->_inline_check_coercion(@_),
+ $self->_inline_check_constraint(@_),
+ );
+}
+
+sub _inline_check_coercion {
+ my $self = shift;
+ my ($value, $tc, $tc_obj) = @_;
+
+ return unless $self->should_coerce && $self->type_constraint->has_coercion;
+
+ return $value . ' = ' . $tc_obj . '->coerce(' . $value . ');';
+}
+
+sub _inline_check_constraint {
+ my $self = shift;
+ my ($value, $tc, $tc_obj) = @_;
+
+ return unless $self->has_type_constraint;
+
+ my $attr_name = quotemeta($self->name);
+
+ return (
+ 'if (!' . $tc . '->(' . $value . ')) {',
+ $self->_inline_throw_error(
+ '"Attribute (' . $attr_name . ') does not pass the type '
+ . 'constraint because: " . '
+ . $tc_obj . '->get_message(' . $value . ')',
+ 'data => ' . $value
+ ) . ';',
+ '}',
+ );
+}
+
+sub _inline_get_old_value_for_trigger {
+ my $self = shift;
+ my ($instance, $old) = @_;
+
+ return unless $self->has_trigger;
+
+ return (
+ 'my ' . $old . ' = ' . $self->_inline_instance_has($instance),
+ '? ' . $self->_inline_instance_get($instance),
+ ': ();',
+ );
+}
+
+sub _inline_weaken_value {
+ my $self = shift;
+ my ($instance, $value) = @_;
+
+ return unless $self->is_weak_ref;
+
+ my $mi = $self->associated_class->get_meta_instance;
+ return (
+ $mi->inline_weaken_slot_value($instance, $self->name, $value),
+ 'if ref ' . $value . ';',
+ );
+}
+
+sub _inline_trigger {
+ my $self = shift;
+ my ($instance, $value, $old) = @_;
+
+ return unless $self->has_trigger;
+
+ return '$attr->trigger->(' . $instance . ', ' . $value . ', ' . $old . ');';
+}
+
sub _weaken_value {
my ( $self, $instance ) = @_;
}
}
+sub _inline_get_value {
+ my $self = shift;
+ my ($instance, $tc, $tc_obj) = @_;
+
+ my $slot_access = $self->_inline_instance_get($instance);
+ $tc ||= '$type_constraint';
+ $tc_obj ||= '$type_constraint_obj';
+
+ return (
+ $self->_inline_check_lazy($instance, $tc, $tc_obj),
+ $self->_inline_return_auto_deref($slot_access),
+ );
+}
+
+sub _inline_check_lazy {
+ my $self = shift;
+ my ($instance, $tc, $tc_obj) = @_;
+
+ return unless $self->is_lazy;
+
+ my $slot_exists = $self->_inline_instance_has($instance);
+
+ return (
+ 'if (!' . $slot_exists . ') {',
+ $self->_inline_init_from_default($instance, '$default', $tc, $tc_obj, 'lazy'),
+ '}',
+ );
+}
+
+sub _inline_init_from_default {
+ my $self = shift;
+ my ($instance, $default, $tc, $tc_obj, $for_lazy) = @_;
+
+ if (!($self->has_default || $self->has_builder)) {
+ $self->throw_error(
+ 'You cannot have a lazy attribute '
+ . '(' . $self->name . ') '
+ . 'without specifying a default value for it',
+ attr => $self,
+ );
+ }
+
+ return (
+ $self->_inline_generate_default($instance, $default),
+ # intentionally not using _inline_tc_code, since that can be overridden
+ # to do things like possibly only do member tc checks, which isn't
+ # appropriate for checking the result of a default
+ $self->has_type_constraint
+ ? ($self->_inline_check_coercion($default, $tc, $tc_obj, $for_lazy),
+ $self->_inline_check_constraint($default, $tc, $tc_obj, $for_lazy))
+ : (),
+ $self->_inline_init_slot($instance, $default),
+ );
+}
+
+sub _inline_generate_default {
+ my $self = shift;
+ my ($instance, $default) = @_;
+
+ if ($self->has_default) {
+ return 'my ' . $default . ' = $attr->default(' . $instance . ');';
+ }
+ elsif ($self->has_builder) {
+ return (
+ 'my ' . $default . ';',
+ 'if (my $builder = ' . $instance . '->can($attr->builder)) {',
+ $default . ' = ' . $instance . '->$builder;',
+ '}',
+ 'else {',
+ 'my $class = ref(' . $instance . ') || ' . $instance . ';',
+ 'my $builder_name = $attr->builder;',
+ 'my $attr_name = $attr->name;',
+ $self->_inline_throw_error(
+ '"$class does not support builder method '
+ . '\'$builder_name\' for attribute \'$attr_name\'"'
+ ) . ';',
+ '}',
+ );
+ }
+ else {
+ $self->throw_error(
+ "Can't generate a default for " . $self->name
+ . " since no default or builder was specified"
+ );
+ }
+}
+
+sub _inline_init_slot {
+ my $self = shift;
+ my ($inv, $value) = @_;
+
+ if ($self->has_initializer) {
+ return '$attr->set_initial_value(' . $inv . ', ' . $value . ');';
+ }
+ else {
+ return $self->_inline_instance_set($inv, $value) . ';';
+ }
+}
+
+sub _inline_return_auto_deref {
+ my $self = shift;
+
+ return 'return ' . $self->_auto_deref(@_) . ';';
+}
+
+sub _auto_deref {
+ my $self = shift;
+ my ($ref_value) = @_;
+
+ return $ref_value unless $self->should_auto_deref;
+
+ my $type_constraint = $self->type_constraint;
+
+ my $sigil;
+ if ($type_constraint->is_a_type_of('ArrayRef')) {
+ $sigil = '@';
+ }
+ elsif ($type_constraint->is_a_type_of('HashRef')) {
+ $sigil = '%';
+ }
+ else {
+ $self->throw_error(
+ 'Can not auto de-reference the type constraint \''
+ . $type_constraint->name
+ . '\'',
+ type_constraint => $type_constraint,
+ );
+ }
+
+ return 'wantarray '
+ . '? ' . $sigil . '{ (' . $ref_value . ') || return } '
+ . ': (' . $ref_value . ')';
+}
+
## installing accessors
sub accessor_metaclass { 'Moose::Meta::Method::Accessor' }
return;
}
-sub inline_set {
- my $self = shift;
- my ( $instance, $value ) = @_;
-
- my $mi = $self->associated_class->get_meta_instance;
-
- my $code
- = $mi->inline_set_slot_value( $instance, $self->slots, $value ) . ";";
- $code
- .= $mi->inline_weaken_slot_value( $instance, $self->slots, $value )
- . " if ref $value;"
- if $self->is_weak_ref;
-
- return $code;
-}
-
sub install_delegation {
my $self = shift;
predicate => 'has_size',
);
+
+If your attribute name starts with an underscore (C<_>), then the clearer
+and predicate will as well:
+
+ has '_size' => (
+ is => 'ro',
+ lazy_build => 1,
+ );
+
+becomes:
+
+ has '_size' => (
+ is => 'ro',
+ lazy => 1,
+ builder => '_build__size',
+ clearer => '_clear_size',
+ predicate => '_has_size',
+ );
+
+Note the doubled underscore in the builder name. Internally, Moose
+simply prepends the attribute name with "_build_" to come up with the
+builder name.
+
=item * documentation
An arbitrary string that can be retrieved later by calling C<<
. $self->_native_type . '::'
. $suffix;
+ Class::MOP::load_class($role);
return Moose::Meta::Class->create_anon_class(
superclasses =>
[ $self->accessor_metaclass, $self->delegation_metaclass ],
$VERSION = eval $VERSION;
our $AUTHORITY = 'cpan:STEVAN';
-use Moose::Meta::Method::Accessor::Native::Array::accessor;
-use Moose::Meta::Method::Accessor::Native::Array::clear;
-use Moose::Meta::Method::Accessor::Native::Array::count;
-use Moose::Meta::Method::Accessor::Native::Array::delete;
-use Moose::Meta::Method::Accessor::Native::Array::elements;
-use Moose::Meta::Method::Accessor::Native::Array::first;
-use Moose::Meta::Method::Accessor::Native::Array::get;
-use Moose::Meta::Method::Accessor::Native::Array::grep;
-use Moose::Meta::Method::Accessor::Native::Array::insert;
-use Moose::Meta::Method::Accessor::Native::Array::is_empty;
-use Moose::Meta::Method::Accessor::Native::Array::join;
-use Moose::Meta::Method::Accessor::Native::Array::map;
-use Moose::Meta::Method::Accessor::Native::Array::natatime;
-use Moose::Meta::Method::Accessor::Native::Array::pop;
-use Moose::Meta::Method::Accessor::Native::Array::push;
-use Moose::Meta::Method::Accessor::Native::Array::reduce;
-use Moose::Meta::Method::Accessor::Native::Array::set;
-use Moose::Meta::Method::Accessor::Native::Array::shift;
-use Moose::Meta::Method::Accessor::Native::Array::shuffle;
-use Moose::Meta::Method::Accessor::Native::Array::splice;
-use Moose::Meta::Method::Accessor::Native::Array::sort;
-use Moose::Meta::Method::Accessor::Native::Array::sort_in_place;
-use Moose::Meta::Method::Accessor::Native::Array::uniq;
-use Moose::Meta::Method::Accessor::Native::Array::unshift;
-
with 'Moose::Meta::Attribute::Native::Trait';
sub _helper_type { 'ArrayRef' }
$VERSION = eval $VERSION;
our $AUTHORITY = 'cpan:STEVAN';
-use Moose::Meta::Method::Accessor::Native::Bool::not;
-use Moose::Meta::Method::Accessor::Native::Bool::set;
-use Moose::Meta::Method::Accessor::Native::Bool::toggle;
-use Moose::Meta::Method::Accessor::Native::Bool::unset;
-
with 'Moose::Meta::Attribute::Native::Trait';
sub _default_is { 'rw' }
$VERSION = eval $VERSION;
our $AUTHORITY = 'cpan:STEVAN';
-use Moose::Meta::Method::Accessor::Native::Code::execute;
-use Moose::Meta::Method::Accessor::Native::Code::execute_method;
-
with 'Moose::Meta::Attribute::Native::Trait';
sub _helper_type { 'CodeRef' }
$VERSION = eval $VERSION;
our $AUTHORITY = 'cpan:STEVAN';
-use Moose::Meta::Method::Accessor::Native::Counter::dec;
-use Moose::Meta::Method::Accessor::Native::Counter::inc;
-use Moose::Meta::Method::Accessor::Native::Counter::reset;
-use Moose::Meta::Method::Accessor::Native::Counter::set;
-
with 'Moose::Meta::Attribute::Native::Trait' =>
{ -excludes => ['_root_types'] };
$VERSION = eval $VERSION;
our $AUTHORITY = 'cpan:STEVAN';
-use Moose::Meta::Method::Accessor::Native::Hash::accessor;
-use Moose::Meta::Method::Accessor::Native::Hash::clear;
-use Moose::Meta::Method::Accessor::Native::Hash::count;
-use Moose::Meta::Method::Accessor::Native::Hash::defined;
-use Moose::Meta::Method::Accessor::Native::Hash::delete;
-use Moose::Meta::Method::Accessor::Native::Hash::elements;
-use Moose::Meta::Method::Accessor::Native::Hash::exists;
-use Moose::Meta::Method::Accessor::Native::Hash::get;
-use Moose::Meta::Method::Accessor::Native::Hash::is_empty;
-use Moose::Meta::Method::Accessor::Native::Hash::keys;
-use Moose::Meta::Method::Accessor::Native::Hash::kv;
-use Moose::Meta::Method::Accessor::Native::Hash::set;
-use Moose::Meta::Method::Accessor::Native::Hash::values;
-
with 'Moose::Meta::Attribute::Native::Trait';
sub _helper_type { 'HashRef' }
$VERSION = eval $VERSION;
our $AUTHORITY = 'cpan:STEVAN';
-use Moose::Meta::Method::Accessor::Native::Number::abs;
-use Moose::Meta::Method::Accessor::Native::Number::add;
-use Moose::Meta::Method::Accessor::Native::Number::div;
-use Moose::Meta::Method::Accessor::Native::Number::mod;
-use Moose::Meta::Method::Accessor::Native::Number::mul;
-use Moose::Meta::Method::Accessor::Native::Number::set;
-use Moose::Meta::Method::Accessor::Native::Number::sub;
-
with 'Moose::Meta::Attribute::Native::Trait';
sub _helper_type { 'Num' }
$VERSION = eval $VERSION;
our $AUTHORITY = 'cpan:STEVAN';
-use Moose::Meta::Method::Accessor::Native::String::append;
-use Moose::Meta::Method::Accessor::Native::String::chomp;
-use Moose::Meta::Method::Accessor::Native::String::chop;
-use Moose::Meta::Method::Accessor::Native::String::clear;
-use Moose::Meta::Method::Accessor::Native::String::inc;
-use Moose::Meta::Method::Accessor::Native::String::length;
-use Moose::Meta::Method::Accessor::Native::String::match;
-use Moose::Meta::Method::Accessor::Native::String::prepend;
-use Moose::Meta::Method::Accessor::Native::String::replace;
-use Moose::Meta::Method::Accessor::Native::String::substr;
-
with 'Moose::Meta::Attribute::Native::Trait';
sub _default_default { q{} }
return $object;
}
+sub _generate_fallback_constructor {
+ my $self = shift;
+ my ($class) = @_;
+ return $class . '->Moose::Object::new(@_)'
+}
+
+sub _inline_params {
+ my $self = shift;
+ my ($params, $class) = @_;
+ return (
+ 'my ' . $params . ' = ',
+ $self->_inline_BUILDARGS($class, '@_'),
+ ';',
+ );
+}
+
+sub _inline_BUILDARGS {
+ my $self = shift;
+ my ($class, $args) = @_;
+
+ my $buildargs = $self->find_method_by_name("BUILDARGS");
+
+ if ($args eq '@_'
+ && (!$buildargs or $buildargs->body == \&Moose::Object::BUILDARGS)) {
+ return (
+ 'do {',
+ 'my $params;',
+ 'if (scalar @_ == 1) {',
+ 'if (!defined($_[0]) || ref($_[0]) ne \'HASH\') {',
+ $self->_inline_throw_error(
+ '"Single parameters to new() must be a HASH ref"',
+ 'data => $_[0]',
+ ) . ';',
+ '}',
+ '$params = { %{ $_[0] } };',
+ '}',
+ 'elsif (@_ % 2) {',
+ 'Carp::carp(',
+ '"The new() method for ' . $class . ' expects a '
+ . 'hash reference or a key/value list. You passed an '
+ . 'odd number of arguments"',
+ ');',
+ '$params = {@_, undef};',
+ '}',
+ 'else {',
+ '$params = {@_};',
+ '}',
+ '$params;',
+ '}',
+ );
+ }
+ else {
+ return $class . '->BUILDARGS(' . $args . ')';
+ }
+}
+
+sub _inline_slot_initializer {
+ my $self = shift;
+ my ($attr, $idx) = @_;
+
+ return (
+ '## ' . $attr->name,
+ $self->_inline_check_required_attr($attr),
+ $self->SUPER::_inline_slot_initializer(@_),
+ );
+}
+
+sub _inline_check_required_attr {
+ my $self = shift;
+ my ($attr) = @_;
+
+ return unless defined $attr->init_arg;
+ return unless $attr->can('is_required') && $attr->is_required;
+ return if $attr->has_default || $attr->has_builder;
+
+ return (
+ 'if (!exists $params->{\'' . $attr->init_arg . '\'}) {',
+ $self->_inline_throw_error(
+ '"Attribute (' . quotemeta($attr->name) . ') is required"'
+ ) . ';',
+ '}',
+ );
+}
+
+# XXX: these two are duplicated from cmop, because we have to pass the tc stuff
+# through to _inline_set_value - this should probably be fixed, but i'm not
+# quite sure how. -doy
+sub _inline_init_attr_from_constructor {
+ my $self = shift;
+ my ($attr, $idx) = @_;
+
+ my @initial_value = $attr->_inline_set_value(
+ '$instance',
+ '$params->{\'' . $attr->init_arg . '\'}',
+ '$type_constraint_bodies[' . $idx . ']',
+ '$type_constraints[' . $idx . ']',
+ 'for constructor',
+ );
+
+ push @initial_value, (
+ '$attrs->[' . $idx . ']->set_initial_value(',
+ '$instance,',
+ $attr->_inline_instance_get('$instance'),
+ ');',
+ ) if $attr->has_initializer;
+
+ return @initial_value;
+}
+
+sub _inline_init_attr_from_default {
+ my $self = shift;
+ my ($attr, $idx) = @_;
+
+ my $default = $self->_inline_default_value($attr, $idx);
+ return unless $default;
+
+ my @initial_value = (
+ 'my $default = ' . $default . ';',
+ $attr->_inline_set_value(
+ '$instance',
+ '$default',
+ '$type_constraint_bodies[' . $idx . ']',
+ '$type_constraints[' . $idx . ']',
+ 'for constructor',
+ ),
+ );
+
+ push @initial_value, (
+ '$attrs->[' . $idx . ']->set_initial_value(',
+ '$instance,',
+ $attr->_inline_instance_get('$instance'),
+ ');',
+ ) if $attr->has_initializer;
+
+ return @initial_value;
+}
+
+sub _inline_extra_init {
+ my $self = shift;
+ return (
+ $self->_inline_triggers,
+ $self->_inline_BUILDALL,
+ );
+}
+
+sub _inline_triggers {
+ my $self = shift;
+ my @trigger_calls;
+
+ my @attrs = sort { $a->name cmp $b->name } $self->get_all_attributes;
+ for my $i (0 .. $#attrs) {
+ my $attr = $attrs[$i];
+
+ next unless $attr->can('has_trigger') && $attr->has_trigger;
+
+ my $init_arg = $attr->init_arg;
+ next unless defined $init_arg;
+
+ push @trigger_calls,
+ 'if (exists $params->{\'' . $init_arg . '\'}) {',
+ '$attrs->[' . $i . ']->trigger->(',
+ '$instance,',
+ $attr->_inline_instance_get('$instance') . ',',
+ ');',
+ '}';
+ }
+
+ return @trigger_calls;
+}
+
+sub _inline_BUILDALL {
+ my $self = shift;
+
+ my @methods = reverse $self->find_all_methods_by_name('BUILD');
+ my @BUILD_calls;
+
+ foreach my $method (@methods) {
+ push @BUILD_calls,
+ '$instance->' . $method->{class} . '::BUILD($params);';
+ }
+
+ return @BUILD_calls;
+}
+
sub superclasses {
my $self = shift;
my $supers = Data::OptList::mkopt(\@_);
$self->raise_error($self->create_error(@args));
}
+sub _inline_throw_error {
+ my ( $self, $msg, $args ) = @_;
+ "\$meta->throw_error($msg" . ($args ? ", $args" : "") . ")"; # FIXME makes deparsing *REALLY* hard
+}
+
sub raise_error {
my ( $self, @args ) = @_;
die @args;
use strict;
use warnings;
+use Try::Tiny;
+
our $VERSION = '1.19';
$VERSION = eval $VERSION;
our $AUTHORITY = 'cpan:STEVAN';
sub _error_thrower {
my $self = shift;
- ( ref $self && $self->associated_attribute ) || $self->SUPER::_error_thrower();
+ return $self->associated_attribute
+ if ref($self) && defined($self->associated_attribute);
+ return $self->SUPER::_error_thrower;
}
-sub _eval_code {
- my ( $self, $source ) = @_;
-
- my $environment = $self->_eval_environment;
-
- my ( $code, $e ) = $self->_compile_code( environment => $environment, code => $source );
-
- $self->throw_error(
- "Could not create writer for '${\$self->associated_attribute->name}' because $e \n code: $source",
- error => $e, data => $source )
- if $e;
-
- return $code;
+sub _compile_code {
+ my $self = shift;
+ my @args = @_;
+ try {
+ $self->SUPER::_compile_code(@args);
+ }
+ catch {
+ $self->throw_error(
+ 'Could not create writer for '
+ . "'" . $self->associated_attribute->name . "' "
+ . 'because ' . $_,
+ error => $_,
+ );
+ };
}
sub _eval_environment {
'$type_constraint_obj' => \$type_constraint_obj,
'$type_constraint' => \(
$type_constraint_obj
- ? $type_constraint_obj->_compiled_type_constraint
- : undef
+ ? $type_constraint_obj->_compiled_type_constraint
+ : undef
),
};
}
-sub _generate_accessor_method_inline {
- my $self = $_[0];
- my $inv = '$_[0]';
- my $value_name = $self->_value_needs_copy ? '$val' : '$_[1]';
-
- $self->_eval_code('sub { ' . "\n"
- . $self->_inline_pre_body(@_) . "\n"
- . 'if (scalar(@_) >= 2) {' . "\n"
- . $self->_inline_copy_value . "\n"
- . $self->_inline_check_required . "\n"
- . $self->_inline_check_coercion($value_name) . "\n"
- . $self->_inline_check_constraint($value_name) . "\n"
- . $self->_inline_get_old_value_for_trigger($inv, $value_name) . "\n"
- . $self->_inline_store($inv, $value_name) . "\n"
- . $self->_inline_trigger($inv, $value_name, '@old') . "\n"
- . ' }' . "\n"
- . $self->_inline_check_lazy($inv) . "\n"
- . $self->_inline_post_body(@_) . "\n"
- . 'return ' . $self->_inline_auto_deref($self->_inline_get($inv)) . "\n"
- . ' }');
-}
-
-sub _generate_writer_method_inline {
- my $self = $_[0];
- my $inv = '$_[0]';
- my $value_name = $self->_value_needs_copy ? '$val' : '$_[1]';
-
- $self->_eval_code('sub { '
- . $self->_inline_pre_body(@_)
- . $self->_inline_copy_value
- . $self->_inline_check_required
- . $self->_inline_check_coercion($value_name)
- . $self->_inline_check_constraint($value_name)
- . $self->_inline_get_old_value_for_trigger($inv, $value_name) . "\n"
- . $self->_inline_store($inv, $value_name)
- . $self->_inline_post_body(@_)
- . $self->_inline_trigger($inv, $value_name, '@old')
- . ' }');
-}
-
-sub _generate_reader_method_inline {
- my $self = $_[0];
- my $inv = '$_[0]';
- my $slot_access = $self->_inline_get($inv);
-
- $self->_eval_code('sub {'
- . $self->_inline_pre_body(@_)
- . $self->_inline_throw_error('"Cannot assign a value to a read-only accessor"', 'data => \@_') . ' if @_ > 1;'
- . $self->_inline_check_lazy($inv)
- . $self->_inline_post_body(@_)
- . 'return ' . $self->_inline_auto_deref( $slot_access ) . ';'
- . '}');
-}
-
-sub _inline_copy_value {
- return '' unless shift->_value_needs_copy;
- return 'my $val = $_[1];'
-}
-
-sub _value_needs_copy {
- my $attr = (shift)->associated_attribute;
- return $attr->should_coerce;
-}
-
sub _instance_is_inlinable {
my $self = shift;
return $self->associated_attribute->associated_class->instance_metaclass->is_inlinable;
: $self->SUPER::_generate_clearer_method(@_);
}
-sub _inline_pre_body { '' }
-sub _inline_post_body { '' }
-
-sub _inline_check_constraint {
- my ($self, $value) = @_;
-
- my $attr = $self->associated_attribute;
-
- return '' unless $attr->has_type_constraint;
-
- my $attr_name = quotemeta( $attr->name );
-
- qq{\$type_constraint->($value) || } . $self->_inline_throw_error(qq{"Attribute ($attr_name) does not pass the type constraint because: " . \$type_constraint_obj->get_message($value)}, "data => $value") . ";";
+sub _writer_value_needs_copy {
+ shift->associated_attribute->_writer_value_needs_copy(@_);
}
-sub _inline_check_coercion {
- my ($self, $value) = @_;
-
- my $attr = $self->associated_attribute;
-
- return '' unless $attr->should_coerce && $attr->type_constraint->has_coercion;
- return "$value = \$attr->type_constraint->coerce($value);";
+sub _inline_tc_code {
+ shift->associated_attribute->_inline_tc_code(@_);
}
-sub _inline_check_required {
- my $self = shift;
- my $attr = $self->associated_attribute;
-
- return '' unless $attr->is_required;
-
- my $attr_name = quotemeta( $attr->name );
-
- return qq{(\@_ >= 2) || } . $self->_inline_throw_error(qq{"Attribute ($attr_name) is required, so cannot be set to undef"}) . ';' # defined $_[1] is not good enough
+sub _inline_check_constraint {
+ shift->associated_attribute->_inline_check_constraint(@_);
}
sub _inline_check_lazy {
- my ($self, $instance) = @_;
-
- my $attr = $self->associated_attribute;
-
- return '' unless $attr->is_lazy;
-
- my $slot_exists = $self->_inline_has($instance);
-
- my $code = 'unless (' . $slot_exists . ') {' . "\n";
- if ($attr->has_type_constraint) {
- if ($attr->has_default || $attr->has_builder) {
- if ($attr->has_default) {
- $code .= ' my $default = $attr->default(' . $instance . ');'."\n";
- }
- elsif ($attr->has_builder) {
- $code .= ' my $default;'."\n".
- ' if(my $builder = '.$instance.'->can($attr->builder)){ '."\n".
- ' $default = '.$instance.'->$builder; '. "\n } else {\n" .
- ' ' . $self->_inline_throw_error(q{sprintf "%s does not support builder method '%s' for attribute '%s'", ref(} . $instance . ') || '.$instance.', $attr->builder, $attr->name') .
- ';'. "\n }";
- }
- $code .= $self->_inline_check_coercion('$default') . "\n";
- $code .= $self->_inline_check_constraint('$default', 'lazy') . "\n";
- $code .= ' ' . $self->_inline_init_slot($attr, $instance, '$default') . "\n";
- }
- else {
- $code .= ' ' . $self->_inline_init_slot($attr, $instance, 'undef') . "\n";
- }
-
- } else {
- if ($attr->has_default) {
- $code .= ' ' . $self->_inline_init_slot($attr, $instance, ('$attr->default(' . $instance . ')')) . "\n";
- }
- elsif ($attr->has_builder) {
- $code .= ' if (my $builder = '.$instance.'->can($attr->builder)) { ' . "\n"
- . ' ' . $self->_inline_init_slot($attr, $instance, ($instance . '->$builder'))
- . "\n } else {\n"
- . ' ' . $self->_inline_throw_error(q{sprintf "%s does not support builder method '%s' for attribute '%s'", ref(} . $instance . ') || '.$instance.', $attr->builder, $attr->name')
- . ';'. "\n }";
- }
- else {
- $code .= ' ' . $self->_inline_init_slot($attr, $instance, 'undef') . "\n";
- }
- }
- $code .= "}\n";
- return $code;
+ shift->associated_attribute->_inline_check_lazy(@_);
}
-sub _inline_init_slot {
- my ($self, $attr, $inv, $value) = @_;
- if ($attr->has_initializer) {
- return ('$attr->set_initial_value(' . $inv . ', ' . $value . ');');
- }
- else {
- return $self->_inline_store($inv, $value);
- }
-}
-
-sub _inline_store {
- my ( $self, $instance, $value ) = @_;
-
- return $self->associated_attribute->inline_set( $instance, $value );
+sub _inline_store_value {
+ shift->associated_attribute->_inline_instance_set(@_) . ';';
}
sub _inline_get_old_value_for_trigger {
- my ( $self, $instance ) = @_;
-
- my $attr = $self->associated_attribute;
- return '' unless $attr->has_trigger;
-
- return
- 'my @old = '
- . $self->_inline_has($instance) . q{ ? }
- . $self->_inline_get($instance) . q{ : ()} . ";\n";
+ shift->associated_attribute->_inline_get_old_value_for_trigger(@_);
}
sub _inline_trigger {
- my ($self, $instance, $value, $old_value) = @_;
- my $attr = $self->associated_attribute;
- return '' unless $attr->has_trigger;
- return sprintf('$attr->trigger->(%s, %s, %s);', $instance, $value, $old_value);
-}
-
-sub _inline_get {
- my ($self, $instance) = @_;
-
- return $self->associated_attribute->inline_get($instance);
+ shift->associated_attribute->_inline_trigger(@_);
}
-sub _inline_has {
- my ($self, $instance) = @_;
-
- return $self->associated_attribute->inline_has($instance);
+sub _get_value {
+ shift->associated_attribute->_inline_instance_get(@_);
}
-sub _inline_auto_deref {
- my ( $self, $ref_value ) = @_;
- my $attr = $self->associated_attribute;
-
- return $ref_value unless $attr->should_auto_deref;
-
- my $type_constraint = $attr->type_constraint;
-
- my $sigil;
- if ($type_constraint->is_a_type_of('ArrayRef')) {
- $sigil = '@';
- }
- elsif ($type_constraint->is_a_type_of('HashRef')) {
- $sigil = '%';
- }
- else {
- $self->throw_error( "Can not auto de-reference the type constraint '"
- . quotemeta( $type_constraint->name )
- . "'", type_constraint => $type_constraint );
- }
-
- "(wantarray() ? $sigil\{ ( $ref_value ) || return } : ( $ref_value ) )";
+sub _has_value {
+ shift->associated_attribute->_inline_instance_has(@_);
}
1;
my $class = shift;
my %options = @_;
- exists $options{curried_arguments}
- || ( $options{curried_arguments} = [] );
+ $options{curried_arguments} = []
+ unless exists $options{curried_arguments};
- ( $options{curried_arguments}
- && ( 'ARRAY' eq ref $options{curried_arguments} ) )
- || confess
- 'You must supply a curried_arguments which is an ARRAY reference';
+ confess 'You must supply a curried_arguments which is an ARRAY reference'
+ unless $options{curried_arguments}
+ && ref($options{curried_arguments}) eq 'ARRAY';
$options{definition_context} = $options{attribute}->definition_context;
return $class->$orig(%options);
};
-around _new => sub {
- shift;
+sub _new {
my $class = shift;
my $options = @_ == 1 ? $_[0] : {@_};
return bless $options, $class;
-};
+}
sub root_types { (shift)->{'root_types'} }
sub _initialize_body {
my $self = shift;
- $self->{'body'} = $self->_eval_code( $self->_generate_method );
+ $self->{'body'} = $self->_compile_code( [$self->_generate_method] );
return;
}
sub _inline_curried_arguments {
my $self = shift;
- return q{} unless @{ $self->curried_arguments };
+ return unless @{ $self->curried_arguments };
- return 'unshift @_, @curried;'
+ return 'unshift @_, @curried;';
}
sub _inline_check_argument_count {
my $self = shift;
- my $code = q{};
-
- if ( my $min = $self->_minimum_arguments ) {
- my $err_msg = sprintf(
- q{"Cannot call %s without at least %s argument%s"},
- $self->delegate_to_method,
- $min,
- ( $min == 1 ? q{} : 's' )
+ my @code;
+
+ if (my $min = $self->_minimum_arguments) {
+ push @code, (
+ 'if (@_ < ' . $min . ') {',
+ $self->_inline_throw_error(
+ sprintf(
+ '"Cannot call %s without at least %s argument%s"',
+ $self->delegate_to_method,
+ $min,
+ ($min == 1 ? '' : 's'),
+ )
+ ) . ';',
+ '}',
);
-
- $code
- .= "\n"
- . $self->_inline_throw_error($err_msg)
- . " unless \@_ >= $min;";
}
- if ( defined( my $max = $self->_maximum_arguments ) ) {
- my $err_msg = sprintf(
- q{"Cannot call %s with %s argument%s"},
- $self->delegate_to_method,
- ( $max ? "more than $max" : 'any' ),
- ( $max == 1 ? q{} : 's' )
+ if (defined(my $max = $self->_maximum_arguments)) {
+ push @code, (
+ 'if (@_ > ' . $max . ') {',
+ $self->_inline_throw_error(
+ sprintf(
+ '"Cannot call %s with %s argument%s"',
+ $self->delegate_to_method,
+ $max ? "more than $max" : 'any',
+ ($max == 1 ? '' : 's'),
+ )
+ ) . ';',
+ '}',
);
-
- $code
- .= "\n"
- . $self->_inline_throw_error($err_msg)
- . " if \@_ > $max;";
}
- return $code;
+ return @code;
+}
+
+sub _inline_return_value {
+ my $self = shift;
+ my ($slot_access, $for_writer) = @_;
+
+ return 'return ' . $self->_return_value($slot_access, $for_writer) . ';';
}
sub _minimum_arguments { 0 }
sub _maximum_arguments { undef }
-override _inline_get => sub {
- my ( $self, $instance ) = @_;
+override _get_value => sub {
+ my $self = shift;
+ my ($instance) = @_;
return $self->_slot_access_can_be_inlined
? super()
- : "${instance}->\$reader";
+ : $instance . '->$reader';
};
-override _inline_store => sub {
- my ( $self, $instance, $value ) = @_;
+override _inline_store_value => sub {
+ my $self = shift;
+ my ($instance, $value) = @_;
return $self->_slot_access_can_be_inlined
? super()
- : "${instance}->\$writer($value)";
+ : $instance . '->$writer(' . $value . ');';
};
override _eval_environment => sub {
our $AUTHORITY = 'cpan:STEVAN';
sub _inline_check_var_is_valid_index {
- my ( $self, $var ) = @_;
-
- return $self->_inline_throw_error( q{'The index passed to }
- . $self->delegate_to_method
- . q{ must be an integer'} )
- . qq{ unless defined $var && $var =~ /^-?\\d+\$/;};
+ my $self = shift;
+ my ($var) = @_;
+
+ return (
+ 'if (!defined(' . $var . ') || ' . $var . ' !~ /^-?\d+$/) {',
+ $self->_inline_throw_error(
+ '"The index passed to ' . $self->delegate_to_method
+ . ' must be an integer"',
+ ) . ';',
+ '}',
+ );
}
no Moose::Role;
use Moose::Role;
-with 'Moose::Meta::Method::Accessor::Native::Writer',
+with 'Moose::Meta::Method::Accessor::Native::Writer' => {
+ -excludes => ['_inline_coerce_new_values'],
+ },
'Moose::Meta::Method::Accessor::Native::Array',
'Moose::Meta::Method::Accessor::Native::Collection';
-sub _new_members {'@_'}
+sub _new_members { '@_' }
-sub _inline_copy_old_value {
- my ( $self, $slot_access ) = @_;
+sub _copy_old_value {
+ my $self = shift;
+ my ($slot_access) = @_;
return '[ @{(' . $slot_access . ')} ]';
}
sub _generate_method {
my $self = shift;
- my $inv = '$self';
-
- my $code = 'sub {';
- $code .= "\n" . $self->_inline_pre_body(@_);
-
- $code .= "\n" . 'my $self = shift;';
-
- $code .= "\n" . $self->_inline_curried_arguments;
-
- $code .= "\n" . $self->_inline_check_lazy($inv);
-
- my $slot_access = $self->_inline_get($inv);
-
- # get
- $code .= "\n" . 'if ( @_ == 1 ) {';
-
- $code .= "\n" . $self->_inline_check_var_is_valid_index('$_[0]');
-
- $code
- .= "\n"
- . 'return '
- . $self
- ->Moose::Meta::Method::Accessor::Native::Array::get::_return_value(
- $slot_access)
- . ';';
-
- # set
- $code .= "\n" . '} else {';
-
- $code .= "\n" . $self->_writer_core( $inv, $slot_access );
-
- $code .= "\n" . $self->_inline_post_body(@_);
-
- $code .= "\n}";
- $code .= "\n}";
-
- return $code;
+ my $inv = '$self';
+ my $slot_access = $self->_get_value($inv);
+
+ return (
+ 'sub {',
+ 'my ' . $inv . ' = shift;',
+ $self->_inline_curried_arguments,
+ $self->_inline_check_lazy($inv, '$type_constraint', '$type_constraint_obj'),
+ # get
+ 'if (@_ == 1) {',
+ $self->_inline_check_var_is_valid_index('$_[0]'),
+ $self->Moose::Meta::Method::Accessor::Native::Array::get::_inline_return_value($slot_access),
+ '}',
+ # set
+ 'else {',
+ $self->_inline_writer_core($inv, $slot_access),
+ '}',
+ '}',
+ );
}
-sub _minimum_arguments {1}
-sub _maximum_arguments {2}
+sub _minimum_arguments { 1 }
+sub _maximum_arguments { 2 }
no Moose::Role;
sub _adds_members { 0 }
-sub _potential_value { return '[]' }
+sub _potential_value { '[]' }
sub _inline_optimized_set_new_value {
- my ( $self, $inv, $new, $slot_access ) = @_;
+ my $self = shift;
+ my ($inv, $new, $slot_access) = @_;
- return "$slot_access = []";
+ return $slot_access . ' = [];';
}
-sub _return_value { return q{} }
+sub _return_value { '' }
no Moose::Role;
sub _maximum_arguments { 0 }
sub _return_value {
- my ( $self, $slot_access ) = @_;
+ my $self = shift;
+ my ($slot_access) = @_;
- return "scalar \@{ ($slot_access) }";
+ return 'scalar @{ (' . $slot_access . ') }';
}
no Moose::Role;
sub _adds_members { 0 }
sub _potential_value {
- my ( $self, $slot_access ) = @_;
+ my $self = shift;
+ my ($slot_access) = @_;
- return
- "( do { my \@potential = \@{ ($slot_access) }; \@return = splice \@potential, \$_[0], 1; \\\@potential } )";
+ return '(do { '
+ . 'my @potential = @{ (' . $slot_access . ') }; '
+ . '@return = splice @potential, $_[0], 1; '
+ . '\@potential; '
+ . '})';
}
sub _inline_optimized_set_new_value {
- my ( $self, $inv, $new, $slot_access ) = @_;
+ my $self = shift;
+ my ($inv, $new, $slot_access) = @_;
- return "\@return = splice \@{ ($slot_access) }, \$_[0], 1";
+ return '@return = splice @{ (' . $slot_access . ') }, $_[0], 1;';
}
sub _return_value {
- my ( $self, $slot_access ) = @_;
+ my $self = shift;
+ my ($slot_access) = @_;
- return 'return $return[0];';
+ return '$return[0]';
}
no Moose::Role;
sub _maximum_arguments { 0 }
sub _return_value {
- my $self = shift;
- my $slot_access = shift;
+ my $self = shift;
+ my ($slot_access) = @_;
- return "\@{ ($slot_access) }";
+ return '@{ (' . $slot_access . ') }';
}
no Moose::Role;
sub _inline_check_arguments {
my $self = shift;
- return $self->_inline_throw_error(
- q{'The argument passed to first must be a code reference'})
- . q{ unless Params::Util::_CODELIKE( $_[0] );};
+ return (
+ 'if (!Params::Util::_CODELIKE($_[0])) {',
+ $self->_inline_throw_error(
+ '"The argument passed to first must be a code reference"',
+ ) . ';',
+ '}',
+ );
}
sub _return_value {
- my $self = shift;
- my $slot_access = shift;
+ my $self = shift;
+ my ($slot_access) = @_;
- return "&List::Util::first( \$_[0], \@{ ($slot_access) } )";
+ return '&List::Util::first($_[0], @{ (' . $slot_access . ') })';
}
no Moose::Role;
}
sub _return_value {
- my $self = shift;
- my $slot_access = shift;
+ my $self = shift;
+ my ($slot_access) = @_;
- return "${slot_access}->[ \$_[0] ]";
+ return $slot_access . '->[ $_[0] ]';
}
1;
sub _inline_check_arguments {
my $self = shift;
- return $self->_inline_throw_error(
- q{'The argument passed to grep must be a code reference'})
- . q{ unless Params::Util::_CODELIKE( $_[0] );};
+ return (
+ 'if (!Params::Util::_CODELIKE($_[0])) {',
+ $self->_inline_throw_error(
+ '"The argument passed to grep must be a code reference"',
+ ) . ';',
+ '}',
+ );
}
sub _return_value {
- my $self = shift;
- my $slot_access = shift;
+ my $self = shift;
+ my ($slot_access) = @_;
- return "grep { \$_[0]->() } \@{ ($slot_access) }";
+ return 'grep { $_[0]->() } @{ (' . $slot_access . ') }';
}
no Moose::Role;
qw(
_minimum_arguments
_maximum_arguments
+ _inline_coerce_new_values
_new_members
_inline_optimized_set_new_value
_return_value
sub _adds_members { 1 }
sub _potential_value {
- my ( $self, $slot_access ) = @_;
+ my $self = shift;
+ my ($slot_access) = @_;
- return
- "( do { my \@potential = \@{ ($slot_access) }; splice \@potential, \$_[0], 0, \$_[1]; \\\@potential } )";
+ return '(do { '
+ . 'my @potential = @{ (' . $slot_access . ') }; '
+ . 'splice @potential, $_[0], 0, $_[1]; '
+ . '\@potential; '
+ . '})';
}
# We need to override this because while @_ can be written to, we cannot write
# directly to $_[1].
-around _inline_coerce_new_values => sub {
- shift;
+sub _inline_coerce_new_values {
my $self = shift;
- return q{} unless $self->associated_attribute->should_coerce;
+ return unless $self->associated_attribute->should_coerce;
- return q{} unless $self->_tc_member_type_can_coerce;
+ return unless $self->_tc_member_type_can_coerce;
- return '@_ = ( $_[0], $member_tc_obj->coerce( $_[1] ) );';
+ return '@_ = ($_[0], $member_tc_obj->coerce($_[1]));';
};
sub _new_members { '$_[1]' }
sub _inline_optimized_set_new_value {
- my ( $self, $inv, $new, $slot_access ) = @_;
+ my $self = shift;
+ my ($inv, $new, $slot_access) = @_;
- return "splice \@{ ($slot_access) }, \$_[0], 0, \$_[1];";
+ return 'splice @{ (' . $slot_access . ') }, $_[0], 0, $_[1];';
}
sub _return_value {
- my ( $self, $slot_access ) = @_;
+ my $self = shift;
+ my ($slot_access) = @_;
- return "return ${slot_access}->[ \$_[0] ];";
+ return $slot_access . '->[ $_[0] ]';
}
no Moose::Role;
sub _maximum_arguments { 0 }
sub _return_value {
- my $self = shift;
- my $slot_access = shift;
+ my $self = shift;
+ my ($slot_access) = @_;
- return "\@{ ($slot_access) } ? 0 : 1";
+ return '@{ (' . $slot_access . ') } ? 0 : 1';
}
no Moose::Role;
sub _inline_check_arguments {
my $self = shift;
- return $self->_inline_throw_error(
- q{'The argument passed to join must be a string'})
- . ' unless Moose::Util::_STRINGLIKE0( $_[0] );';
+ return (
+ 'if (!Moose::Util::_STRINGLIKE0($_[0])) {',
+ $self->_inline_throw_error(
+ '"The argument passed to join must be a string"',
+ ) . ';',
+ '}',
+ );
}
sub _return_value {
- my $self = shift;
- my $slot_access = shift;
+ my $self = shift;
+ my ($slot_access) = @_;
- return "join \$_[0], \@{ ($slot_access) }";
+ return 'join $_[0], @{ (' . $slot_access . ') }';
}
no Moose::Role;
sub _inline_check_arguments {
my $self = shift;
- return $self->_inline_throw_error(
- q{'The argument passed to map must be a code reference'})
- . q{ unless Params::Util::_CODELIKE( $_[0] );};
+ return (
+ 'if (!Params::Util::_CODELIKE($_[0])) {',
+ $self->_inline_throw_error(
+ '"The argument passed to map must be a code reference"',
+ ) . ';',
+ '}',
+ );
}
sub _return_value {
- my $self = shift;
- my $slot_access = shift;
+ my $self = shift;
+ my ($slot_access) = @_;
- return "map { \$_[0]->() } \@{ ($slot_access) }";
+ return 'map { $_[0]->() } @{ (' . $slot_access . ') }';
}
no Moose::Role;
]
};
-sub _minimum_arguments {1}
+sub _minimum_arguments { 1 }
-sub _maximum_arguments {2}
+sub _maximum_arguments { 2 }
sub _inline_check_arguments {
my $self = shift;
- return $self->_inline_throw_error(
- q{'The n value passed to natatime must be an integer'})
- . ' unless defined $_[0] && $_[0] =~ /^\\d+$/;' . "\n"
- . $self->_inline_throw_error(
- q{'The second argument passed to natatime must be a code reference'})
- . q{ if @_ == 2 && ! Params::Util::_CODELIKE( $_[1] );};
+ return (
+ 'if (!defined($_[0]) || $_[0] !~ /^\d+$/) {',
+ $self->_inline_throw_error(
+ '"The n value passed to natatime must be an integer"',
+ ) . ';',
+ '}',
+ 'if (@_ == 2 && !Params::Util::_CODELIKE($_[1])) {',
+ $self->_inline_throw_error(
+ '"The second argument passed to natatime must be a code '
+ . 'reference"',
+ ) . ';',
+ '}',
+ );
}
sub _inline_return_value {
- my ( $self, $slot_access ) = @_;
-
- return
- "my \$iter = List::MoreUtils::natatime( \$_[0], \@{ ($slot_access) } );"
- . "\n"
- . 'if ( $_[1] ) {' . "\n"
- . 'while (my @vals = $iter->()) {' . "\n"
- . '$_[1]->(@vals);' . "\n" . '}' . "\n"
- . '} else {' . "\n"
- . 'return $iter;' . "\n" . '}';
+ my $self = shift;
+ my ($slot_access) = @_;
+
+ return (
+ 'my $iter = List::MoreUtils::natatime($_[0], @{ (' . $slot_access . ') });',
+ 'if ($_[1]) {',
+ 'while (my @vals = $iter->()) {',
+ '$_[1]->(@vals);',
+ '}',
+ '}',
+ 'else {',
+ 'return $iter;',
+ '}',
+ );
}
# Not called, but needed to satisfy the Reader role
sub _adds_members { 0 }
sub _potential_value {
- my ( $self, $slot_access ) = @_;
+ my $self = shift;
+ my ($slot_access) = @_;
- return "[ \@{ ($slot_access) } > 1 ? \@{ ($slot_access) }[ 0 .. \$#{ ($slot_access) } - 1 ] : () ]";
+ return '[ @{ (' . $slot_access . ') } > 1 '
+ . '? @{ (' . $slot_access . ') }[0..$#{ (' . $slot_access . ') } - 1] '
+ . ': () ]';
}
sub _inline_capture_return_value {
- my ( $self, $slot_access ) = @_;
+ my $self = shift;
+ my ($slot_access) = @_;
- return "my \$old = ${slot_access}->[-1];";
+ return 'my $old = ' . $slot_access . '->[-1];';
}
sub _inline_optimized_set_new_value {
- my ( $self, $inv, $new, $slot_access ) = @_;
+ my $self = shift;
+ my ($inv, $new, $slot_access) = @_;
- return "pop \@{ ($slot_access) }";
+ return 'pop @{ (' . $slot_access . ') };';
}
sub _return_value {
- my ( $self, $slot_access ) = @_;
+ my $self = shift;
+ my ($slot_access) = @_;
- return 'return $old;';
+ return '$old';
}
no Moose::Role;
sub _adds_members { 1 }
sub _potential_value {
- my ( $self, $slot_access ) = @_;
+ my $self = shift;
+ my ($slot_access) = @_;
- return "[ \@{ ($slot_access) }, \@_ ]";
+ return '[ @{ (' . $slot_access . ') }, @_ ]';
}
sub _inline_optimized_set_new_value {
- my ( $self, $inv, $new, $slot_access ) = @_;
+ my $self = shift;
+ my ($inv, $new, $slot_access) = @_;
- return "push \@{ ($slot_access) }, \@_";
+ return 'push @{ (' . $slot_access . ') }, @_;';
}
sub _return_value {
- my ( $self, $slot_access ) = @_;
+ my $self = shift;
+ my ($slot_access) = @_;
- return "return scalar \@{ ($slot_access) }";
+ return 'scalar @{ (' . $slot_access . ') }';
}
no Moose::Role;
sub _inline_check_arguments {
my $self = shift;
- return $self->_inline_throw_error(
- q{'The argument passed to reduce must be a code reference'})
- . q{ unless Params::Util::_CODELIKE( $_[0] );};
+ return (
+ 'if (!Params::Util::_CODELIKE($_[0])) {',
+ $self->_inline_throw_error(
+ '"The argument passed to reduce must be a code reference"',
+ ) . ';',
+ '}',
+ );
}
sub _return_value {
- my $self = shift;
- my $slot_access = shift;
+ my $self = shift;
+ my ($slot_access) = @_;
- return "List::Util::reduce { \$_[0]->( \$a, \$b ) } \@{ ($slot_access) }";
+ return 'List::Util::reduce { $_[0]->($a, $b) } @{ (' . $slot_access . ') }';
}
no Moose::Role;
_minimum_arguments
_maximum_arguments
_inline_check_arguments
+ _inline_coerce_new_values
_new_members
_inline_optimized_set_new_value
_return_value
sub _adds_members { 1 }
sub _potential_value {
- my ( $self, $slot_access ) = @_;
+ my $self = shift;
+ my ($slot_access) = @_;
- return
- "( do { my \@potential = \@{ ($slot_access) }; \$potential[ \$_[0] ] = \$_[1]; \\\@potential } )";
+ return '(do { '
+ . 'my @potential = @{ (' . $slot_access . ') }; '
+ . '$potential[$_[0]] = $_[1]; '
+ . '\@potential; '
+ . '})';
}
# We need to override this because while @_ can be written to, we cannot write
# directly to $_[1].
-around _inline_coerce_new_values => sub {
- shift;
+sub _inline_coerce_new_values {
my $self = shift;
- return q{} unless $self->associated_attribute->should_coerce;
+ return unless $self->associated_attribute->should_coerce;
- return q{} unless $self->_tc_member_type_can_coerce;
+ return unless $self->_tc_member_type_can_coerce;
- return '@_ = ( $_[0], $member_tc_obj->coerce( $_[1] ) );';
+ return '@_ = ($_[0], $member_tc_obj->coerce($_[1]));';
};
sub _new_members { '$_[1]' }
sub _inline_optimized_set_new_value {
- my ( $self, $inv, $new, $slot_access ) = @_;
+ my $self = shift;
+ my ($inv, $new, $slot_access) = @_;
- return "${slot_access}->[ \$_[0] ] = \$_[1]";
+ return $slot_access . '->[$_[0]] = $_[1];';
}
sub _return_value {
- my ( $self, $slot_access ) = @_;
+ my $self = shift;
+ my ($slot_access) = @_;
- return "return ${slot_access}->[ \$_[0] ];";
+ return $slot_access . '->[$_[0]]';
}
no Moose::Role;
sub _adds_members { 0 }
sub _potential_value {
- my ( $self, $slot_access ) = @_;
+ my $self = shift;
+ my ($slot_access) = @_;
- return "[ \@{ ($slot_access) } > 1 ? \@{ ($slot_access) }[ 1 .. \$#{ ($slot_access) } ] : () ]";
+ return '[ @{ (' . $slot_access . ') } > 1 '
+ . '? @{ (' . $slot_access . ') }[1..$#{ (' . $slot_access . ') }] '
+ . ': () ]';
}
sub _inline_capture_return_value {
- my ( $self, $slot_access ) = @_;
+ my $self = shift;
+ my ($slot_access) = @_;
- return "my \$old = ${slot_access}->[0];";
+ return 'my $old = ' . $slot_access . '->[0];';
}
sub _inline_optimized_set_new_value {
- my ( $self, $inv, $new, $slot_access ) = @_;
+ my $self = shift;
+ my ($inv, $new, $slot_access) = @_;
- return "shift \@{ ($slot_access) };";
+ return 'shift @{ (' . $slot_access . ') };';
}
sub _return_value {
- my ( $self, $slot_access ) = @_;
+ my $self = shift;
+ my ($slot_access) = @_;
- return 'return $old';
+ return '$old';
}
no Moose::Role;
sub _maximum_arguments { 0 }
sub _return_value {
- my $self = shift;
- my $slot_access = shift;
+ my $self = shift;
+ my ($slot_access) = @_;
- return "List::Util::shuffle \@{ ($slot_access) }";
+ return 'List::Util::shuffle @{ (' . $slot_access . ') }';
}
no Moose::Role;
sub _inline_check_arguments {
my $self = shift;
- return $self->_inline_throw_error(
- q{'The argument passed to sort must be a code reference'})
- . q{ if @_ && ! Params::Util::_CODELIKE( $_[0] );};
+ return (
+ 'if (@_ && !Params::Util::_CODELIKE($_[0])) {',
+ $self->_inline_throw_error(
+ '"The argument passed to sort must be a code reference"',
+ ) . ';',
+ '}',
+ );
}
sub _return_value {
- my $self = shift;
- my $slot_access = shift;
+ my $self = shift;
+ my ($slot_access) = @_;
- return
- "\$_[0] ? sort { \$_[0]->( \$a, \$b ) } \@{ ($slot_access) } : sort \@{ ($slot_access) }";
+ return '$_[0] '
+ . '? sort { $_[0]->($a, $b) } @{ (' . $slot_access . ') } '
+ . ': sort @{ (' . $slot_access . ') }';
}
no Moose::Role;
sub _inline_check_arguments {
my $self = shift;
- return $self->_inline_throw_error(
- q{'The argument passed to sort_in_place must be a code reference'})
- . q{ if @_ && ! Params::Util::_CODELIKE( $_[0] );};
+ return (
+ 'if (@_ && !Params::Util::_CODELIKE($_[0])) {',
+ $self->_inline_throw_error(
+ '"The argument passed to sort_in_place must be a code '
+ . 'reference"',
+ ) . ';',
+ '}',
+ );
}
sub _adds_members { 0 }
sub _potential_value {
- my ( $self, $slot_access ) = @_;
+ my $self = shift;
+ my ($slot_access) = @_;
- return
- "[ \$_[0] ? sort { \$_[0]->( \$a, \$b ) } \@{ ($slot_access) } : sort \@{ ($slot_access) } ]";
+ return '[ $_[0] '
+ . '? sort { $_[0]->($a, $b) } @{ (' . $slot_access . ') } '
+ . ': sort @{ (' . $slot_access . ') } ]';
}
-sub _return_value { return q{} }
+sub _return_value { '' }
no Moose::Role;
sub _adds_members { 1 }
sub _inline_process_arguments {
- return 'my $idx = shift;' . "\n" . 'my $len = @_ ? shift : undef;';
+ return (
+ 'my $idx = shift;',
+ 'my $len = @_ ? shift : undef;',
+ );
}
sub _inline_check_arguments {
my $self = shift;
- return
- $self->_inline_check_var_is_valid_index('$idx') . "\n"
- . $self->_inline_throw_error(q{'The length argument passed to splice must be an integer'})
- . ' if defined $len && $len !~ /^-?\\d+$/;';
+ return (
+ $self->_inline_check_var_is_valid_index('$idx'),
+ 'if (defined($len) && $len !~ /^-?\d+$/) {',
+ $self->_inline_throw_error(
+ '"The length argument passed to splice must be an integer"',
+ ) . ';',
+ '}',
+ );
}
sub _potential_value {
- my ( $self, $slot_access ) = @_;
-
- return "( do { my \@potential = \@{ ($slot_access) };"
- . '@return = defined $len ? ( splice @potential, $idx, $len, @_ ) : ( splice @potential, $idx ); \\@potential } )';
+ my $self = shift;
+ my ($slot_access) = @_;
+
+ return '(do { '
+ . 'my @potential = @{ (' . $slot_access . ') }; '
+ . '@return = defined $len '
+ . '? (splice @potential, $idx, $len, @_) '
+ . ': (splice @potential, $idx); '
+ . '\@potential;'
+ . '})';
}
sub _inline_optimized_set_new_value {
- my ( $self, $inv, $new, $slot_access ) = @_;
+ my $self = shift;
+ my ($inv, $new, $slot_access) = @_;
- return "\@return = defined \$len ? ( splice \@{ ($slot_access) }, \$idx, \$len, \@_ ) : ( splice \@{ ($slot_access) }, \$idx )";
+ return (
+ '@return = defined $len',
+ '? (splice @{ (' . $slot_access . ') }, $idx, $len, @_)',
+ ': (splice @{ (' . $slot_access . ') }, $idx);',
+ );
}
sub _return_value {
- my ($self, $slot_access) = @_;
+ my $self = shift;
+ my ($slot_access) = @_;
- return 'return wantarray ? @return : $return[-1]';
+ return 'wantarray ? @return : $return[-1]';
}
no Moose::Role;
sub _maximum_arguments { 0 }
sub _return_value {
- my $self = shift;
- my $slot_access = shift;
+ my $self = shift;
+ my ($slot_access) = @_;
- return "List::MoreUtils::uniq \@{ ($slot_access) }";
+ return 'List::MoreUtils::uniq @{ (' . $slot_access . ') }';
}
no Moose::Role;
sub _adds_members { 1 }
sub _potential_value {
- my ( $self, $slot_access ) = @_;
+ my $self = shift;
+ my ($slot_access) = @_;
- return "[ \@_, \@{ ($slot_access) } ]";
+ return '[ @_, @{ (' . $slot_access . ') } ]';
}
sub _inline_optimized_set_new_value {
- my ( $self, $inv, $new, $slot_access ) = @_;
+ my $self = shift;
+ my ($inv, $new, $slot_access) = @_;
- return "unshift \@{ ($slot_access) }, \@_";
+ return 'unshift @{ (' . $slot_access . ') }, @_;';
}
sub _return_value {
- my ( $self, $slot_access ) = @_;
+ my $self = shift;
+ my ($slot_access) = @_;
- return "return scalar \@{ ($slot_access) }";
+ return 'scalar @{ (' . $slot_access . ') }';
}
no Moose::Role;
sub _maximum_arguments { 0 }
sub _return_value {
- my ( $self, $slot_access ) = @_;
+ my $self = shift;
+ my ($slot_access) = @_;
- return "! $slot_access";
+ return '!' . $slot_access;
}
1;
sub _potential_value { 1 }
sub _inline_optimized_set_new_value {
- my ( $self, $inv, $new, $slot_access ) = @_;
+ my $self = shift;
+ my ($inv, $new, $slot_access) = @_;
- return "$slot_access = 1";
+ return $slot_access . ' = 1;';
}
no Moose::Role;
sub _maximum_arguments { 0 }
sub _potential_value {
- my ( $self, $slot_access ) = @_;
+ my $self = shift;
+ my ($slot_access) = @_;
- return "$slot_access ? 0 : 1";
+ return $slot_access . ' ? 0 : 1';
}
sub _inline_optimized_set_new_value {
- my ( $self, $inv, $new, $slot_access ) = @_;
+ my $self = shift;
+ my ($inv, $new, $slot_access) = @_;
- return "$slot_access = $slot_access ? 0 : 1";
+ return $slot_access . ' = ' . $slot_access . ' ? 0 : 1;';
}
no Moose::Role;
sub _potential_value { 0 }
sub _inline_optimized_set_new_value {
- my ( $self, $inv, $new, $slot_access ) = @_;
+ my $self = shift;
+ my ($inv, $new, $slot_access) = @_;
- return "$slot_access = 0";
+ return $slot_access . ' = 0;';
}
no Moose::Role;
with 'Moose::Meta::Method::Accessor::Native::Reader';
sub _return_value {
- my ( $self, $slot_access ) = @_;
+ my $self = shift;
+ my ($slot_access) = @_;
- return "${slot_access}->(\@_)";
+ return $slot_access . '->(@_)';
}
no Moose::Role;
with 'Moose::Meta::Method::Accessor::Native::Reader';
sub _return_value {
- my ( $self, $slot_access ) = @_;
+ my $self = shift;
+ my ($slot_access) = @_;
- return "${slot_access}->(\$self, \@_)";
+ return $slot_access . '->($self, @_)';
}
no Moose::Role;
requires qw( _adds_members );
-around _inline_coerce_new_values => sub {
- shift;
+sub _inline_coerce_new_values {
my $self = shift;
- return q{} unless $self->associated_attribute->should_coerce;
+ return unless $self->associated_attribute->should_coerce;
- return q{} unless $self->_tc_member_type_can_coerce;
+ return unless $self->_tc_member_type_can_coerce;
- return
- '('
- . $self->_new_members
- . ') = map { $member_tc_obj->coerce($_) } '
- . $self->_new_members . ';';
-};
+ return (
+ '(' . $self->_new_members . ') = map { $member_tc_obj->coerce($_) }',
+ $self->_new_members . ';',
+ );
+}
sub _tc_member_type_can_coerce {
my $self = shift;
sub _tc_member_type {
my $self = shift;
- for (
- my $tc = $self->associated_attribute->type_constraint;
- $tc;
- $tc = $tc->parent
- ) {
-
+ my $tc = $self->associated_attribute->type_constraint;
+ while ($tc) {
return $tc->type_parameter
if $tc->can('type_parameter');
+ $tc = $tc->parent;
}
return;
}
-around _value_needs_copy => sub {
- shift;
+sub _writer_value_needs_copy {
my $self = shift;
return $self->_constraint_must_be_checked
&& !$self->_check_new_members_only;
-};
+}
-around _inline_tc_code => sub {
- shift;
- my ( $self, $potential_value ) = @_;
+sub _inline_tc_code {
+ my $self = shift;
- return q{} unless $self->_constraint_must_be_checked;
+ return unless $self->_constraint_must_be_checked;
- if ( $self->_check_new_members_only ) {
- return q{} unless $self->_adds_members;
+ if ($self->_check_new_members_only) {
+ return unless $self->_adds_members;
- return $self->_inline_check_member_constraint( $self->_new_members );
+ return $self->_inline_check_member_constraint($self->_new_members);
}
else {
- return $self->_inline_check_coercion($potential_value) . "\n"
- . $self->_inline_check_constraint($potential_value);
+ return (
+ $self->_inline_check_coercion(@_),
+ $self->_inline_check_constraint(@_),
+ );
}
-};
+}
sub _check_new_members_only {
my $self = shift;
}
sub _inline_check_member_constraint {
- my ( $self, $new_value ) = @_;
+ my $self = shift;
+ my ($new_value) = @_;
my $attr_name = $self->associated_attribute->name;
- return '$member_tc->($_) || '
- . $self->_inline_throw_error(
- qq{"A new member value for '$attr_name' does not pass its type constraint because: "}
- . ' . $member_tc_obj->get_message($_)',
- "data => \$_"
- ) . " for $new_value;";
+ return (
+ 'for (' . $new_value . ') {',
+ 'if (!$member_tc->($_)) {',
+ $self->_inline_throw_error(
+ '"A new member value for ' . $attr_name
+ . ' does not pass its type constraint because: "'
+ . ' . $member_tc_obj->get_message($_)',
+ 'data => $_',
+ ) . ';',
+ '}',
+ '}',
+ );
}
-around _inline_get_old_value_for_trigger => sub {
- shift;
- my ( $self, $instance ) = @_;
+sub _inline_get_old_value_for_trigger {
+ my $self = shift;
+ my ($instance, $old) = @_;
my $attr = $self->associated_attribute;
- return '' unless $attr->has_trigger;
+ return unless $attr->has_trigger;
- return
- 'my @old = '
- . $self->_inline_has($instance) . q{ ? }
- . $self->_inline_copy_old_value( $self->_inline_get($instance) )
- . ": ();\n";
-};
+ return (
+ 'my ' . $old . ' = ' . $self->_has_value($instance),
+ '? ' . $self->_copy_old_value($self->_get_value($instance)),
+ ': ();',
+ );
+}
around _eval_environment => sub {
my $orig = shift;
my $attr = $self->associated_attribute;
return $attr->has_type_constraint
- && ( $attr->type_constraint->name =~ /^(?:Num|Int)$/
- || ( $attr->should_coerce && $attr->type_constraint->has_coercion ) );
+ && ($attr->type_constraint->name =~ /^(?:Num|Int)$/
+ || ($attr->should_coerce && $attr->type_constraint->has_coercion)
+ );
}
no Moose::Role;
]
};
-sub _minimum_arguments {0}
-sub _maximum_arguments {1}
+sub _minimum_arguments { 0 }
+sub _maximum_arguments { 1 }
sub _potential_value {
- my ( $self, $slot_access ) = @_;
+ my $self = shift;
+ my ($slot_access) = @_;
- return "$slot_access - ( defined \$_[0] ? \$_[0] : 1 )";
+ return $slot_access . ' - (defined $_[0] ? $_[0] : 1)';
}
sub _inline_optimized_set_new_value {
- my ( $self, $inv, $new, $slot_access ) = @_;
+ my $self = shift;
+ my ($inv, $new, $slot_access) = @_;
- return "$slot_access -= defined \$_[0] ? \$_[0] : 1";
+ return $slot_access . ' -= defined $_[0] ? $_[0] : 1;';
}
no Moose::Role;
sub _maximum_arguments { 1 }
sub _potential_value {
- my ( $self, $slot_access ) = @_;
+ my $self = shift;
+ my ($slot_access) = @_;
- return "$slot_access + ( defined \$_[0] ? \$_[0] : 1 )";
+ return $slot_access . ' + (defined $_[0] ? $_[0] : 1)';
}
sub _inline_optimized_set_new_value {
- my ( $self, $inv, $new, $slot_access ) = @_;
+ my $self = shift;
+ my ($inv, $new, $slot_access) = @_;
- return "$slot_access += defined \$_[0] ? \$_[0] : 1";
+ return $slot_access . ' += defined $_[0] ? $_[0] : 1;';
}
no Moose::Role;
sub _maximum_arguments { 0 }
sub _potential_value {
- my ( $self, $slot_access ) = @_;
+ my $self = shift;
+ my ($slot_access) = @_;
- return "\$attr->default(\$self)"
+ return '$attr->default($self)';
}
sub _inline_optimized_set_new_value {
- my ( $self, $inv, $new, $slot_access ) = @_;
+ my $self = shift;
+ my ($inv, $new, $slot_access) = @_;
- return "$slot_access = \$attr->default(\$self)";
+ return $slot_access . ' = $attr->default($self);';
}
no Moose::Role;
]
};
-sub _minimum_arguments {1}
-sub _maximum_arguments {1}
+sub _minimum_arguments { 1 }
+sub _maximum_arguments { 1 }
-sub _potential_value {'$_[0]'}
+sub _potential_value { '$_[0]' }
sub _inline_optimized_set_new_value {
- my ( $self, $inv, $new, $slot_access ) = @_;
+ my $self = shift;
+ my ($inv, $new, $slot_access) = @_;
- return "$slot_access = \$_[0];";
+ return $slot_access . ' = $_[0];';
}
no Moose::Role;
use Moose::Role;
sub _inline_check_var_is_valid_key {
- my ( $self, $var ) = @_;
+ my $self = shift;
+ my ($var) = @_;
- return $self->_inline_throw_error( q{'The key passed to }
- . $self->delegate_to_method
- . q{ must be a defined value'} )
- . qq{ unless defined $var;};
+ return (
+ 'if (!defined(' . $var . ')) {',
+ $self->_inline_throw_error(
+ '"The key passed to ' . $self->delegate_to_method
+ . ' must be a defined value"',
+ ) . ';',
+ '}',
+ );
}
no Moose::Role;
use Moose::Role;
-with 'Moose::Meta::Method::Accessor::Native::Writer',
+with 'Moose::Meta::Method::Accessor::Native::Writer' => {
+ -excludes => ['_inline_coerce_new_values'],
+ },
'Moose::Meta::Method::Accessor::Native::Hash',
'Moose::Meta::Method::Accessor::Native::Collection';
-sub _new_values {'@values'}
+sub _new_values { '@values' }
-sub _inline_copy_old_value {
- my ( $self, $slot_access ) = @_;
+sub _copy_old_value {
+ my $self = shift;
+ my ($slot_access) = @_;
- return '{ %{(' . $slot_access . ')} }';
+ return '{ %{ (' . $slot_access . ') } }';
}
no Moose::Role;
sub _generate_method {
my $self = shift;
- my $inv = '$self';
-
- my $code = 'sub {';
- $code .= "\n" . $self->_inline_pre_body(@_);
-
- $code .= "\n" . 'my $self = shift;';
-
- $code .= "\n" . $self->_inline_curried_arguments;
-
- $code .= "\n" . $self->_inline_check_lazy($inv);
-
- my $slot_access = $self->_inline_get($inv);
-
- # get
- $code .= "\n" . 'if ( @_ == 1 ) {';
-
- $code .= "\n" . $self->_inline_check_var_is_valid_key('$_[0]');
-
- $code
- .= "\n"
- . 'return '
- . $self
- ->Moose::Meta::Method::Accessor::Native::Hash::get::_return_value(
- $slot_access)
- . ';';
-
- # set
- $code .= "\n" . '} else {';
-
- $code .= "\n" . $self->_writer_core( $inv, $slot_access );
-
- $code .= "\n" . $self->_inline_post_body(@_);
-
- $code .= "\n}";
- $code .= "\n}";
-
- return $code;
+ my $inv = '$self';
+ my $slot_access = $self->_get_value($inv);
+
+ return (
+ 'sub {',
+ 'my ' . $inv . ' = shift;',
+ $self->_inline_curried_arguments,
+ $self->_inline_check_lazy($inv, '$type_constraint', '$type_constraint_obj'),
+ # get
+ 'if (@_ == 1) {',
+ $self->_inline_check_var_is_valid_key('$_[0]'),
+ $self->Moose::Meta::Method::Accessor::Native::Hash::get::_inline_return_value($slot_access),
+ '}',
+ # set
+ 'else {',
+ $self->_inline_writer_core($inv, $slot_access),
+ '}',
+ '}',
+ );
}
-sub _minimum_arguments {1}
-sub _maximum_arguments {2}
+sub _minimum_arguments { 1 }
+sub _maximum_arguments { 2 }
no Moose::Role;
sub _adds_members { 0 }
-sub _potential_value { return '{}' }
+sub _potential_value { '{}' }
sub _inline_optimized_set_new_value {
- my ( $self, $inv, $new, $slot_access ) = @_;
+ my $self = shift;
+ my ($inv, $new, $slot_access) = @_;
- return "$slot_access = {}";
+ return $slot_access . ' = {};';
}
-sub _return_value { return q{} }
+sub _return_value { '' }
no Moose::Role;
sub _maximum_arguments { 0 }
sub _return_value {
- my $self = shift;
- my $slot_access = shift;
+ my $self = shift;
+ my ($slot_access) = @_;
- return "scalar keys \%{ ($slot_access) }";
+ return 'scalar keys %{ (' . $slot_access . ') }';
}
no Moose::Role;
}
sub _return_value {
- my $self = shift;
- my $slot_access = shift;
+ my $self = shift;
+ my ($slot_access) = @_;
- return "defined ${slot_access}->{ \$_[0] }";
+ return 'defined ' . $slot_access . '->{ $_[0] }';
}
no Moose::Role;
sub _adds_members { 0 }
sub _potential_value {
- my ( $self, $slot_access ) = @_;
-
- return "( do { my \%potential = %{ ($slot_access) }; \@return = delete \@potential{\@_}; \\\%potential; } )";
+ my $self = shift;
+ my ($slot_access) = @_;
+
+ return '(do { '
+ . 'my %potential = %{ (' . $slot_access . ') }; '
+ . '@return = delete @potential{@_}; '
+ . '\%potential; '
+ . '})';
}
sub _inline_optimized_set_new_value {
- my ( $self, $inv, $new, $slot_access ) = @_;
+ my $self = shift;
+ my ($inv, $new, $slot_access) = @_;
- return "\@return = delete \@{ ($slot_access) }{\@_}";
+ return '@return = delete @{ (' . $slot_access . ') }{@_};';
}
sub _return_value {
- my ( $self, $slot_access ) = @_;
+ my $self = shift;
+ my ($slot_access) = @_;
- return 'return wantarray ? @return : $return[-1];';
+ return 'wantarray ? @return : $return[-1]';
}
no Moose::Role;
sub _maximum_arguments { 0 }
sub _return_value {
- my $self = shift;
- my $slot_access = shift;
+ my $self = shift;
+ my ($slot_access) = @_;
- return "map { \$_, ${slot_access}->{\$_} } keys \%{ ($slot_access) }";
+ return 'map { $_, ' . $slot_access . '->{$_} } '
+ . 'keys %{ (' . $slot_access . ') }';
}
no Moose::Role;
}
sub _return_value {
- my $self = shift;
- my $slot_access = shift;
+ my $self = shift;
+ my ($slot_access) = shift;
- return "exists ${slot_access}->{ \$_[0] }";
+ return 'exists ' . $slot_access . '->{ $_[0] }';
}
no Moose::Role;
sub _inline_check_arguments {
my $self = shift;
- return
- 'for (@_) {' . "\n"
- . $self->_inline_check_var_is_valid_key('$_') . "\n" . '}';
+ return (
+ 'for (@_) {',
+ $self->_inline_check_var_is_valid_key('$_'),
+ '}',
+ );
}
sub _return_value {
- my $self = shift;
- my $slot_access = shift;
+ my $self = shift;
+ my ($slot_access) = @_;
- return "\@_ > 1 ? \@{ ($slot_access) }{\@_} : ${slot_access}->{ \$_[0] }";
+ return '@_ > 1 '
+ . '? @{ (' . $slot_access . ') }{@_} '
+ . ': ' . $slot_access . '->{$_[0]}';
}
no Moose::Role;
sub _maximum_arguments { 0 }
sub _return_value {
- my $self = shift;
- my $slot_access = shift;
+ my $self = shift;
+ my ($slot_access) = @_;
- return "scalar keys \%{ ($slot_access) } ? 0 : 1";
+ return 'scalar keys %{ (' . $slot_access . ') } ? 0 : 1';
}
no Moose::Role;
sub _maximum_arguments { 0 }
sub _return_value {
- my $self = shift;
- my $slot_access = shift;
+ my $self = shift;
+ my ($slot_access) = @_;
- return "keys \%{ ($slot_access) }";
+ return 'keys %{ (' . $slot_access . ') }';
}
no Moose::Role;
sub _maximum_arguments { 0 }
sub _return_value {
- my $self = shift;
- my $slot_access = shift;
+ my $self = shift;
+ my ($slot_access) = @_;
- return "map { [ \$_, ${slot_access}->{\$_} ] } keys \%{ ($slot_access) }";
+ return 'map { [ $_, ' . $slot_access . '->{$_} ] } '
+ . 'keys %{ (' . $slot_access . ') }';
}
no Moose::Role;
_maximum_arguments
_inline_process_arguments
_inline_check_arguments
+ _inline_coerce_new_values
_inline_optimized_set_new_value
_return_value
)
my $orig = shift;
my $self = shift;
- return
- $self->$orig(@_) . "\n"
- . $self->_inline_throw_error(
- q{'You must pass an even number of arguments to set'})
- . ' if @_ % 2;';
+ return (
+ $self->$orig(@_),
+ 'if (@_ % 2) {',
+ $self->_inline_throw_error(
+ '"You must pass an even number of arguments to set"',
+ ) . ';',
+ '}',
+ );
};
sub _inline_process_arguments {
my $self = shift;
- return 'my @keys_idx = grep { ! ($_ % 2) } 0..$#_;' . "\n"
- . 'my @values_idx = grep { $_ % 2 } 0..$#_;';
+ return (
+ 'my @keys_idx = grep { ! ($_ % 2) } 0..$#_;',
+ 'my @values_idx = grep { $_ % 2 } 0..$#_;',
+ );
}
sub _inline_check_arguments {
my $self = shift;
- return
- 'for (@keys_idx) {' . "\n"
- . $self->_inline_throw_error(
- q{'Hash keys passed to set must be defined'})
- . ' unless defined $_[$_];' . "\n" . '}';
+ return (
+ 'for (@keys_idx) {',
+ 'if (!defined($_[$_])) {',
+ $self->_inline_throw_error(
+ '"Hash keys passed to set must be defined"',
+ ) . ';',
+ '}',
+ '}',
+ );
}
sub _adds_members { 1 }
# We need to override this because while @_ can be written to, we cannot write
# directly to $_[1].
-around _inline_coerce_new_values => sub {
- shift;
+sub _inline_coerce_new_values {
my $self = shift;
- return q{} unless $self->associated_attribute->should_coerce;
+ return unless $self->associated_attribute->should_coerce;
- return q{} unless $self->_tc_member_type_can_coerce;
+ return unless $self->_tc_member_type_can_coerce;
# Is there a simpler way to do this?
- return 'my $iter = List::MoreUtils::natatime 2, @_;'
- . '@_ = ();'
- . 'while ( my ( $key, $val ) = $iter->() ) {'
- . 'push @_, $key, $member_tc_obj->coerce($val);'
- . '}';
+ return (
+ 'my $iter = List::MoreUtils::natatime(2, @_);',
+ '@_ = ();',
+ 'while (my ($key, $val) = $iter->()) {',
+ 'push @_, $key, $member_tc_obj->coerce($val);',
+ '}',
+ );
};
sub _potential_value {
- my ( $self, $slot_access ) = @_;
+ my $self = shift;
+ my ($slot_access) = @_;
- return "{ %{ ($slot_access) }, \@_ }";
+ return '{ %{ (' . $slot_access . ') }, @_ }';
}
sub _new_members { '@_[ @values_idx ]' }
sub _inline_optimized_set_new_value {
- my ( $self, $inv, $new, $slot_access ) = @_;
+ my $self = shift;
+ my ($inv, $new, $slot_access) = @_;
- return "\@{ ($slot_access) }{ \@_[ \@keys_idx] } = \@_[ \@values_idx ]";
+ return '@{ (' . $slot_access . ') }{ @_[@keys_idx] } = @_[@values_idx];';
}
sub _return_value {
- my ( $self, $slot_access ) = @_;
+ my $self = shift;
+ my ($slot_access) = @_;
- return "return wantarray ? \@{ ($slot_access) }{ \@_[ \@keys_idx ] } : ${slot_access}->{ \$_[ \$keys_idx[0] ] };";
+ return 'wantarray '
+ . '? @{ (' . $slot_access . ') }{ @_[@keys_idx] } '
+ . ': ' . $slot_access . '->{ $_[$keys_idx[0]] }';
}
no Moose::Role;
sub _maximum_arguments { 0 }
sub _return_value {
- my $self = shift;
- my $slot_access = shift;
+ my $self = shift;
+ my ($slot_access) = @_;
- return "values \%{ ($slot_access) }";
+ return 'values %{ (' . $slot_access . ') }';
}
no Moose::Role;
]
};
-sub _maximum_arguments {0}
+sub _maximum_arguments { 0 }
sub _potential_value {
- my ( $self, $slot_access ) = @_;
+ my $self = shift;
+ my ($slot_access) = @_;
- return "abs($slot_access)";
+ return 'abs(' . $slot_access . ')';
}
sub _inline_optimized_set_new_value {
- my ( $self, $inv, $new, $slot_access ) = @_;
+ my $self = shift;
+ my ($inv, $new, $slot_access) = @_;
- return "$slot_access = abs($slot_access)";
+ return $slot_access . ' = abs(' . $slot_access . ');';
}
no Moose::Role;
]
};
-sub _minimum_arguments {1}
+sub _minimum_arguments { 1 }
-sub _maximum_arguments {1}
+sub _maximum_arguments { 1 }
sub _potential_value {
- my ( $self, $slot_access ) = @_;
+ my $self = shift;
+ my ($slot_access) = @_;
- return "$slot_access + \$_[0]";
+ return $slot_access . ' + $_[0]';
}
sub _inline_optimized_set_new_value {
- my ( $self, $inv, $new, $slot_access ) = @_;
+ my $self = shift;
+ my ($inv, $new, $slot_access) = @_;
- return "$slot_access += \$_[0]";
+ return $slot_access . ' += $_[0];';
}
no Moose::Role;
]
};
-sub _minimum_arguments {1}
+sub _minimum_arguments { 1 }
-sub _maximum_arguments {1}
+sub _maximum_arguments { 1 }
sub _potential_value {
- my ( $self, $slot_access ) = @_;
+ my $self = shift;
+ my ($slot_access) = @_;
- return "$slot_access / \$_[0]";
+ return $slot_access . ' / $_[0]';
}
sub _inline_optimized_set_new_value {
- my ( $self, $inv, $new, $slot_access ) = @_;
+ my $self = shift;
+ my ($inv, $new, $slot_access) = @_;
- return "$slot_access /= \$_[0]";
+ return $slot_access . ' /= $_[0];';
}
no Moose::Role;
]
};
-sub _minimum_arguments {1}
+sub _minimum_arguments { 1 }
-sub _maximum_arguments {1}
+sub _maximum_arguments { 1 }
sub _potential_value {
- my ( $self, $slot_access ) = @_;
+ my $self = shift;
+ my ($slot_access) = @_;
- return "$slot_access % \$_[0]";
+ return $slot_access . ' % $_[0]';
}
sub _inline_optimized_set_new_value {
- my ( $self, $inv, $new, $slot_access ) = @_;
+ my $self = shift;
+ my ($inv, $new, $slot_access) = @_;
- return "$slot_access %= \$_[0]";
+ return $slot_access . ' %= $_[0];';
}
no Moose::Role;
]
};
-sub _minimum_arguments {1}
+sub _minimum_arguments { 1 }
-sub _maximum_arguments {1}
+sub _maximum_arguments { 1 }
sub _potential_value {
- my ( $self, $slot_access ) = @_;
+ my $self = shift;
+ my ($slot_access) = @_;
- return "$slot_access * \$_[0]";
+ return $slot_access . ' * $_[0]';
}
sub _inline_optimized_set_new_value {
- my ( $self, $inv, $new, $slot_access ) = @_;
+ my $self = shift;
+ my ($inv, $new, $slot_access) = @_;
- return "$slot_access *= \$_[0]";
+ return $slot_access . ' *= $_[0];';
}
no Moose::Role;
]
};
-sub _minimum_arguments {1}
-sub _maximum_arguments {1}
+sub _minimum_arguments { 1 }
+sub _maximum_arguments { 1 }
-sub _potential_value {'$_[0]'}
+sub _potential_value { '$_[0]' }
sub _inline_optimized_set_new_value {
- my ( $self, $inv, $new, $slot_access ) = @_;
+ my $self = shift;
+ my ($inv, $new, $slot_access) = @_;
- return "$slot_access = \$_[0]";
+ return $slot_access . ' = $_[0];';
}
no Moose::Role;
]
};
-sub _minimum_arguments {1}
+sub _minimum_arguments { 1 }
-sub _maximum_arguments {1}
+sub _maximum_arguments { 1 }
sub _potential_value {
- my ( $self, $slot_access ) = @_;
+ my $self = shift;
+ my ($slot_access) = @_;
- return "$slot_access - \$_[0]";
+ return $slot_access . ' - $_[0]';
}
sub _inline_optimized_set_new_value {
- my ( $self, $inv, $new, $slot_access ) = @_;
+ my $self = shift;
+ my ($inv, $new, $slot_access) = @_;
- return "$slot_access -= \$_[0]";
+ return $slot_access . ' -= $_[0];';
}
no Moose::Role;
sub _generate_method {
my $self = shift;
- my $inv = '$self';
-
- my $code = 'sub {';
- $code .= "\n" . $self->_inline_pre_body(@_);
-
- $code .= "\n" . 'my $self = shift;';
-
- $code .= "\n" . $self->_inline_curried_arguments;
-
- my $slot_access = $self->_inline_get($inv);
-
- $code .= "\n" . $self->_reader_core( $inv, $slot_access, @_ );
-
- $code .= "\n}";
-
- return $code;
+ my $inv = '$self';
+ my $slot_access = $self->_get_value($inv);
+
+ return (
+ 'sub {',
+ 'my ' . $inv . ' = shift;',
+ $self->_inline_curried_arguments,
+ $self->_inline_reader_core($inv, $slot_access, @_),
+ '}',
+ );
}
-sub _reader_core {
- my ( $self, $inv, $slot_access, @extra ) = @_;
-
- my $code = q{};
-
- $code .= "\n" . $self->_inline_check_argument_count;
- $code .= "\n" . $self->_inline_process_arguments( $inv, $slot_access );
- $code .= "\n" . $self->_inline_check_arguments;
-
- $code .= "\n" . $self->_inline_check_lazy($inv);
- $code .= "\n" . $self->_inline_post_body(@extra);
- $code .= "\n" . $self->_inline_return_value($slot_access);
-
- return $code;
+sub _inline_reader_core {
+ my $self = shift;
+ my ($inv, $slot_access, @extra) = @_;
+
+ return (
+ $self->_inline_check_argument_count,
+ $self->_inline_process_arguments($inv, $slot_access),
+ $self->_inline_check_arguments,
+ $self->_inline_check_lazy($inv, '$type_constraint', '$type_constraint_obj'),
+ $self->_inline_return_value($slot_access),
+ );
}
-sub _inline_process_arguments {q{}}
+sub _inline_process_arguments { return }
-sub _inline_check_arguments {q{}}
-
-sub _inline_return_value {
- my ( $self, $slot_access ) = @_;
-
- 'return ' . $self->_return_value($slot_access) . ';';
-}
+sub _inline_check_arguments { return }
no Moose::Role;
sub _maximum_arguments { 1 }
sub _potential_value {
- my ( $self, $slot_access ) = @_;
+ my $self = shift;
+ my ($slot_access) = @_;
- return "( $slot_access . \$_[0] )";
+ return '( ' . $slot_access . ' . $_[0] )';
}
sub _inline_optimized_set_new_value {
- my ( $self, $inv, $new, $slot_access ) = @_;
+ my $self = shift;
+ my ($inv, $new, $slot_access) = @_;
- return "$slot_access .= \$_[0]";
+ return $slot_access . ' .= $_[0];';
}
no Moose::Role;
]
};
-sub _maximum_arguments {0}
+sub _maximum_arguments { 0 }
sub _potential_value {
- my ( $self, $slot_access ) = @_;
-
- return "( do { my \$val = $slot_access; \@return = chomp \$val; \$val } )";
+ my $self = shift;
+ my ($slot_access) = @_;
+
+ return '(do { '
+ . 'my $val = ' . $slot_access . '; '
+ . '@return = chomp $val; '
+ . '$val '
+ . '})';
}
sub _inline_optimized_set_new_value {
- my ( $self, $inv, $new, $slot_access ) = @_;
+ my $self = shift;
+ my ($inv, $new, $slot_access) = @_;
- return "\@return = chomp $slot_access";
+ return '@return = chomp ' . $slot_access . ';';
}
sub _return_value {
- my ( $self, $slot_access ) = @_;
+ my $self = shift;
+ my ($slot_access) = @_;
return '$return[0]';
}
sub _maximum_arguments { 0 }
sub _potential_value {
- my ( $self, $slot_access ) = @_;
-
- return "( do { my \$val = $slot_access; \@return = chop \$val; \$val } )";
+ my $self = shift;
+ my ($slot_access) = @_;
+
+ return '(do { '
+ . 'my $val = ' . $slot_access . '; '
+ . '@return = chop $val; '
+ . '$val; '
+ . '})';
}
sub _inline_optimized_set_new_value {
- my ( $self, $inv, $new, $slot_access ) = @_;
+ my $self = shift;
+ my ($inv, $new, $slot_access) = @_;
- return "\@return = chop $slot_access";
+ return '@return = chop ' . $slot_access . ';';
}
sub _return_value {
- my ( $self, $slot_access ) = @_;
+ my $self = shift;
+ my ($slot_access) = @_;
return '$return[0]';
}
sub _maximum_arguments { 0 }
-sub _potential_value {
- my ( $self, $slot_access ) = @_;
-
- return "q{}";
-}
+sub _potential_value { '""' }
sub _inline_optimized_set_new_value {
- my ( $self, $inv, $new, $slot_access ) = @_;
+ my $self = shift;
+ my ($inv, $new, $slot_access) = @_;
- return "$slot_access = q{}";
+ return $slot_access . ' = "";';
}
no Moose::Role;
sub _maximum_arguments { 0 }
sub _potential_value {
- my ( $self, $slot_access ) = @_;
-
- return "( do { my \$val = $slot_access; \$val++; \$val } )";
+ my $self = shift;
+ my ($slot_access) = @_;
+
+ return '(do { '
+ . 'my $val = ' . $slot_access . '; '
+ . '$val++; '
+ . '$val; '
+ . '})';
}
sub _inline_optimized_set_new_value {
- my ( $self, $inv, $new, $slot_access ) = @_;
+ my $self = shift;
+ my ($inv, $new, $slot_access) = @_;
- return "${slot_access}++";
+ return $slot_access . '++;';
}
no Moose::Role;
sub _maximum_arguments { 0 }
sub _return_value {
- my ( $self, $slot_access ) = @_;
+ my $self = shift;
+ my ($slot_access) = @_;
- return "length $slot_access";
+ return 'length ' . $slot_access;
}
no Moose::Role;
sub _inline_check_arguments {
my $self = shift;
- return $self->_inline_throw_error(
- q{'The argument passed to match must be a string or regexp reference'}
- ) . q{ unless Moose::Util::_STRINGLIKE0( $_[0] ) || Params::Util::_REGEX( $_[0] );};
+ return (
+ 'if (!Moose::Util::_STRINGLIKE0($_[0]) && !Params::Util::_REGEX($_[0])) {',
+ $self->_inline_throw_error(
+ '"The argument passed to match must be a string or regexp '
+ . 'reference"',
+ ) . ';',
+ '}',
+ );
}
sub _return_value {
- my ( $self, $slot_access ) = @_;
+ my $self = shift;
+ my ($slot_access) = @_;
- return "$slot_access =~ \$_[0]";
+ return $slot_access . ' =~ $_[0]';
}
no Moose::Role;
sub _maximum_arguments { 1 }
sub _potential_value {
- my ( $self, $slot_access ) = @_;
+ my $self = shift;
+ my ($slot_access) = @_;
- return "( \$_[0] . $slot_access )";
+ return '$_[0] . ' . $slot_access;
}
sub _inline_optimized_set_new_value {
- my ( $self, $inv, $new, $slot_access ) = @_;
+ my $self = shift;
+ my ($inv, $new, $slot_access) = @_;
- return "$slot_access = \$_[0] . $slot_access";
+ return $slot_access . ' = $_[0] . ' . $slot_access . ';';
}
no Moose::Role;
sub _inline_check_arguments {
my $self = shift;
- return $self->_inline_throw_error(
- q{'The first argument passed to replace must be a string or regexp reference'}
- )
- . q{ unless Moose::Util::_STRINGLIKE0( $_[0] ) || Params::Util::_REGEX( $_[0] );}
- . $self->_inline_throw_error(
- q{'The second argument passed to replace must be a string or code reference'}
- ) . q{ unless Moose::Util::_STRINGLIKE0( $_[1] ) || Params::Util::_CODELIKE( $_[1] );};
+ return (
+ 'if (!Moose::Util::_STRINGLIKE0($_[0]) && !Params::Util::_REGEX($_[0])) {',
+ $self->_inline_throw_error(
+ '"The first argument passed to replace must be a string or '
+ . 'regexp reference"'
+ ) . ';',
+ '}',
+ 'if (!Moose::Util::_STRINGLIKE0($_[1]) && !Params::Util::_CODELIKE($_[1])) {',
+ $self->_inline_throw_error(
+ '"The second argument passed to replace must be a string or '
+ . 'code reference"'
+ ) . ';',
+ '}',
+ );
}
sub _potential_value {
- my ( $self, $slot_access ) = @_;
+ my $self = shift;
+ my ($slot_access) = @_;
- return "( do { my \$val = $slot_access; ref \$_[1] ? \$val =~ s/\$_[0]/\$_[1]->()/e : \$val =~ s/\$_[0]/\$_[1]/; \$val } )";
+ return '(do { '
+ . 'my $val = ' . $slot_access . '; '
+ . 'ref $_[1] '
+ . '? $val =~ s/$_[0]/$_[1]->()/e '
+ . ': $val =~ s/$_[0]/$_[1]/; '
+ . '$val; '
+ . '})';
}
sub _inline_optimized_set_new_value {
- my ( $self, $inv, $new, $slot_access ) = @_;
+ my $self = shift;
+ my ($inv, $new, $slot_access) = @_;
- return "if ( ref \$_[1] ) { $slot_access =~ s/\$_[0]/\$_[1]->()/e; } else { $slot_access =~ s/\$_[0]/\$_[1]/; }";
+ return (
+ 'ref $_[1]',
+ '? ' . $slot_access . ' =~ s/$_[0]/$_[1]->()/e',
+ ': ' . $slot_access . ' =~ s/$_[0]/$_[1]/;',
+ );
}
no Moose::Role;
sub _generate_method {
my $self = shift;
- my $inv = '$self';
-
- my $slot_access = $self->_inline_get($inv);
-
- my $code = 'sub {';
-
- $code .= "\n" . $self->_inline_pre_body(@_);
- $code .= "\n" . 'my $self = shift;';
-
- $code .= "\n" . $self->_inline_curried_arguments;
-
- $code .= "\n" . 'if ( @_ == 1 || @_ == 2 ) {';
-
- $code .= $self->_reader_core( $inv, $slot_access );
-
- $code .= "\n" . '} elsif ( @_ == 3 ) {';
-
- $code .= $self->_writer_core( $inv, $slot_access );
-
- $code .= "\n" . $self->_inline_post_body(@_);
-
- $code .= "\n" . '} else {';
-
- $code .= "\n" . $self->_inline_check_argument_count;
-
- $code .= "\n" . '}';
- $code .= "\n" . '}';
-
- return $code;
+ my $inv = '$self';
+ my $slot_access = $self->_get_value($inv);
+
+ return (
+ 'sub {',
+ 'my ' . $inv . ' = shift;',
+ $self->_inline_curried_arguments,
+ 'if (@_ == 1 || @_ == 2) {',
+ $self->_inline_reader_core($inv, $slot_access),
+ '}',
+ 'elsif (@_ == 3) {',
+ $self->_inline_writer_core($inv, $slot_access),
+ '}',
+ 'else {',
+ $self->_inline_check_argument_count,
+ '}',
+ '}',
+ );
}
-sub _minimum_arguments {1}
-sub _maximum_arguments {3}
+sub _minimum_arguments { 1 }
+sub _maximum_arguments { 3 }
sub _inline_process_arguments {
- my ( $self, $inv, $slot_access ) = @_;
+ my $self = shift;
+ my ($inv, $slot_access) = @_;
- return
- 'my $offset = shift;' . "\n"
- . "my \$length = \@_ ? shift : length $slot_access;" . "\n"
- . 'my $replacement = shift;';
+ return (
+ 'my $offset = shift;',
+ 'my $length = @_ ? shift : length ' . $slot_access . ';',
+ 'my $replacement = shift;',
+ );
}
sub _inline_check_arguments {
- my ( $self, $for_writer ) = @_;
-
- my $code
- = $self->_inline_throw_error(
- q{'The first argument passed to substr must be an integer'})
- . q{ unless $offset =~ /^-?\\d+$/;} . "\n"
- . $self->_inline_throw_error(
- q{'The second argument passed to substr must be an integer'})
- . q{ unless $length =~ /^-?\\d+$/;};
+ my $self = shift;
+ my ($for_writer) = @_;
+
+ my @code = (
+ 'if ($offset !~ /^-?\d+$/) {',
+ $self->_inline_throw_error(
+ '"The first argument passed to substr must be an integer"'
+ ) . ';',
+ '}',
+ 'if ($length !~ /^-?\d+$/) {',
+ $self->_inline_throw_error(
+ '"The second argument passed to substr must be an integer"'
+ ) . ';',
+ '}',
+ );
if ($for_writer) {
- $code
- .= "\n"
- . $self->_inline_throw_error(
- q{'The third argument passed to substr must be a string'})
- . q{ unless Moose::Util::_STRINGLIKE0($replacement);};
+ push @code, (
+ 'if (!Moose::Util::_STRINGLIKE0($replacement)) {',
+ $self->_inline_throw_error(
+ '"The third argument passed to substr must be a string"'
+ ) . ';',
+ '}',
+ );
}
- return $code;
+ return @code;
}
sub _potential_value {
- my ( $self, $slot_access ) = @_;
+ my $self = shift;
+ my ($slot_access) = @_;
- return
- "( do { my \$potential = $slot_access; \@return = substr \$potential, \$offset, \$length, \$replacement; \$potential; } )";
+ return '(do { '
+ . 'my $potential = ' . $slot_access . '; '
+ . '@return = substr $potential, $offset, $length, $replacement; '
+ . '$potential; '
+ . '})';
}
sub _inline_optimized_set_new_value {
- my ( $self, $inv, $new, $slot_access ) = @_;
+ my $self = shift;
+ my ($inv, $new, $slot_access) = @_;
- return "\@return = substr $slot_access, \$offset, \$length, \$replacement";
+ return '@return = substr ' . $slot_access . ', '
+ . '$offset, $length, $replacement;';
}
sub _return_value {
- my ( $self, $slot_access, $for_writer ) = @_;
+ my $self = shift;
+ my ($slot_access, $for_writer) = @_;
return '$return[0]' if $for_writer;
- return "substr $slot_access, \$offset, \$length";
+ return 'substr ' . $slot_access . ', $offset, $length';
}
no Moose::Role;
sub _generate_method {
my $self = shift;
- my $inv = '$self';
-
- my $slot_access = $self->_inline_get($inv);
-
- my $code = 'sub {';
-
- $code .= "\n" . $self->_inline_pre_body(@_);
-
- $code .= "\n" . 'my $self = shift;';
-
- $code .= "\n" . $self->_inline_curried_arguments;
-
- $code .= $self->_writer_core( $inv, $slot_access );
-
- $code .= "\n" . $self->_inline_post_body(@_);
-
- $code .= "\n}";
-
- return $code;
+ my $inv = '$self';
+ my $slot_access = $self->_get_value($inv);
+
+ return (
+ 'sub {',
+ 'my ' . $inv . ' = shift;',
+ $self->_inline_curried_arguments,
+ $self->_inline_writer_core($inv, $slot_access),
+ '}',
+ );
}
-sub _writer_core {
- my ( $self, $inv, $slot_access ) = @_;
-
- my $code = q{};
-
- $code .= "\n" . $self->_inline_check_argument_count;
- $code .= "\n" . $self->_inline_process_arguments( $inv, $slot_access );
- $code .= "\n" . $self->_inline_check_arguments('for writer');
+sub _inline_writer_core {
+ my $self = shift;
+ my ($inv, $slot_access) = @_;
- $code .= "\n" . $self->_inline_check_lazy($inv);
+ my $potential = $self->_potential_value($slot_access);
+ my $old = '@old';
- my $potential_value = $self->_potential_value($slot_access);
+ my @code;
+ push @code, (
+ $self->_inline_check_argument_count,
+ $self->_inline_process_arguments($inv, $slot_access),
+ $self->_inline_check_arguments('for writer'),
+ $self->_inline_check_lazy($inv, '$type_constraint', '$type_constraint_obj'),
+ );
- if ( $self->_return_value($slot_access) ) {
+ if ($self->_return_value($slot_access)) {
# some writers will save the return value in this variable when they
# generate the potential value.
- $code .= "\n" . 'my @return;';
+ push @code, 'my @return;'
}
- # This is only needed by collections.
- $code .= "\n" . $self->_inline_coerce_new_values;
- $code .= "\n" . $self->_inline_copy_native_value( \$potential_value );
- $code .= "\n"
- . $self->_inline_tc_code(
- $potential_value
- );
-
- $code .= "\n" . $self->_inline_get_old_value_for_trigger($inv);
- $code .= "\n" . $self->_inline_capture_return_value($slot_access);
- $code .= "\n"
- . $self->_inline_set_new_value(
- $inv,
- $potential_value,
- $slot_access,
- ) . ';';
- $code .= "\n" . $self->_inline_trigger( $inv, $slot_access, '@old' );
- $code .= "\n" . $self->_return_value( $slot_access, 'for writer' );
-
- return $code;
+ push @code, (
+ $self->_inline_coerce_new_values,
+ $self->_inline_copy_native_value(\$potential),
+ $self->_inline_tc_code($potential, '$type_constraint', '$type_constraint_obj'),
+ $self->_inline_get_old_value_for_trigger($inv, $old),
+ $self->_inline_capture_return_value($slot_access),
+ $self->_inline_set_new_value($inv, $potential, $slot_access),
+ $self->_inline_trigger($inv, $slot_access, $old),
+ $self->_inline_return_value($slot_access, 'for writer'),
+ );
+
+ return @code;
}
-sub _inline_process_arguments {q{}}
+sub _inline_process_arguments { return }
-sub _inline_check_arguments {q{}}
+sub _inline_check_arguments { return }
-sub _inline_coerce_new_values {q{}}
+sub _inline_coerce_new_values { return }
-sub _value_needs_copy {
+sub _writer_value_needs_copy {
my $self = shift;
return $self->_constraint_must_be_checked;
my $attr = $self->associated_attribute;
return $attr->has_type_constraint
- && ( !$self->_is_root_type( $attr->type_constraint )
- || ( $attr->should_coerce && $attr->type_constraint->has_coercion ) );
+ && (!$self->_is_root_type( $attr->type_constraint )
+ || ( $attr->should_coerce && $attr->type_constraint->has_coercion)
+ );
}
sub _is_root_type {
- my ($self, $type) = @_;
+ my $self = shift;
+ my ($type) = @_;
- my $name = $type->name();
+ my $name = $type->name;
return any { $name eq $_ } @{ $self->root_types };
}
sub _inline_copy_native_value {
- my ( $self, $potential_ref ) = @_;
+ my $self = shift;
+ my ($potential_ref) = @_;
- return q{} unless $self->_value_needs_copy;
+ return unless $self->_writer_value_needs_copy;
- my $code = "my \$potential = ${$potential_ref};";
+ my $code = 'my $potential = ' . ${$potential_ref} . ';';
${$potential_ref} = '$potential';
return $code;
}
-sub _inline_tc_code {
- my ( $self, $potential_value ) = @_;
+around _inline_tc_code => sub {
+ my $orig = shift;
+ my $self = shift;
+ my ($value, $tc, $tc_obj, $for_lazy) = @_;
- return q{} unless $self->_constraint_must_be_checked;
+ return unless $for_lazy || $self->_constraint_must_be_checked;
- return $self->_inline_check_coercion($potential_value) . "\n"
- . $self->_inline_check_constraint($potential_value);
-}
+ return $self->$orig(@_);
+};
sub _inline_check_coercion {
- my ( $self, $value ) = @_;
+ my $self = shift;
+ my ($value, $tc, $tc_obj) = @_;
my $attr = $self->associated_attribute;
-
- return q{}
- unless $attr->should_coerce
- && $attr->type_constraint->has_coercion;
+ return unless $attr->should_coerce && $attr->type_constraint->has_coercion;
# We want to break the aliasing in @_ in case the coercion tries to make a
# destructive change to an array member.
- return "$value = \$type_constraint_obj->coerce($value);";
+ return $value . ' = ' . $tc_obj . '->coerce(' . $value . ');';
}
-override _inline_check_constraint => sub {
- my ( $self, $value, $for_lazy ) = @_;
+around _inline_check_constraint => sub {
+ my $orig = shift;
+ my $self = shift;
+ my ($value, $tc, $tc_obj, $for_lazy) = @_;
- return q{} unless $for_lazy || $self->_constraint_must_be_checked;
+ return unless $for_lazy || $self->_constraint_must_be_checked;
- return super();
+ return $self->$orig(@_);
};
-sub _inline_capture_return_value { return q{} }
+sub _inline_capture_return_value { return }
sub _inline_set_new_value {
my $self = shift;
- return $self->_inline_store(@_)
- if $self->_value_needs_copy
+ return $self->_inline_store_value(@_)
+ if $self->_writer_value_needs_copy
|| !$self->_slot_access_can_be_inlined
- || !$self->_inline_get_is_lvalue;
+ || !$self->_get_is_lvalue;
return $self->_inline_optimized_set_new_value(@_);
}
-sub _inline_get_is_lvalue {
+sub _get_is_lvalue {
my $self = shift;
return $self->associated_attribute->associated_class->instance_metaclass->inline_get_is_lvalue;
sub _inline_optimized_set_new_value {
my $self = shift;
- return $self->_inline_store(@_);
+ return $self->_inline_store_value(@_);
}
sub _return_value {
- my ( $self, $slot_access ) = @_;
+ my $self = shift;
+ my ($slot_access) = @_;
return $slot_access;
}
use Carp ();
use Scalar::Util 'blessed', 'weaken', 'looks_like_number', 'refaddr';
+use Try::Tiny;
our $VERSION = '1.19';
our $AUTHORITY = 'cpan:STEVAN';
sub _initialize_body {
my $self = shift;
- # TODO:
- # the %options should also include a both
- # a call 'initializer' and call 'SUPER::'
- # options, which should cover approx 90%
- # of the possible use cases (even if it
- # requires some adaption on the part of
- # the author, after all, nothing is free)
- my $source = 'sub {';
- $source .= "\n" . 'my $_instance = shift;';
-
- $source .= "\n" . 'my $class = Scalar::Util::blessed($_instance) || $_instance;';
-
- $source .= "\n" . "if (\$class ne '" . $self->associated_metaclass->name
- . "') {";
- $source .= "\n return "
- . $self->_generate_fallback_constructor('$class') . ";";
- $source .= "\n}\n";
-
- $source .= $self->_generate_params('$params', '$class');
- $source .= $self->_generate_instance('$instance', '$class');
- $source .= $self->_generate_slot_initializers;
-
- $source .= $self->_generate_triggers();
- $source .= ";\n" . $self->_generate_BUILDALL();
-
- $source .= ";\nreturn \$instance";
- $source .= ";\n" . '}';
- warn $source if $self->options->{debug};
+ $self->{'body'} = $self->_generate_constructor_method_inline;
+}
+
+sub _eval_environment {
+ my $self = shift;
+
+ my $attrs = $self->_attributes;
+
+ my $defaults = [map { $_->default } @$attrs];
# We need to check if the attribute ->can('type_constraint')
# since we may be trying to immutabilize a Moose meta class,
# because the inlined code is using the index of the attributes
# to determine where to find the type constraint
- my $attrs = $self->_attributes;
-
my @type_constraints = map {
$_->can('type_constraint') ? $_->type_constraint : undef
} @$attrs;
defined $_ ? $_->_compiled_type_constraint : undef;
} @type_constraints;
- my $defaults = [map { $_->default } @$attrs];
-
- my ( $code, $e ) = $self->_compile_code(
- code => $source,
- environment => {
- '$meta' => \$self,
- '$attrs' => \$attrs,
- '$defaults' => \$defaults,
- '@type_constraints' => \@type_constraints,
- '@type_constraint_bodies' => \@type_constraint_bodies,
- },
- );
-
- $self->throw_error(
- "Could not eval the constructor :\n\n$source\n\nbecause :\n\n$e",
- error => $e, data => $source )
- if $e;
-
- $self->{'body'} = $code;
-}
-
-sub _generate_fallback_constructor {
- my ( $self, $class_var ) = @_;
- "${class_var}->Moose::Object::new(\@_)";
-}
-
-sub _generate_params {
- my ( $self, $var, $class_var ) = @_;
- "my $var = " . $self->_generate_BUILDARGS( $class_var, '@_' ) . ";\n";
-}
-
-sub _generate_instance {
- my ( $self, $var, $class_var ) = @_;
- "my $var = "
- . $self->associated_metaclass->inline_create_instance($class_var) . ";\n";
-}
-
-sub _generate_slot_initializers {
- my ($self) = @_;
- return (join ";\n" => map {
- $self->_generate_slot_initializer($_)
- } 0 .. (@{$self->_attributes} - 1)) . ";\n";
-}
-
-sub _generate_BUILDARGS {
- my ( $self, $class, $args ) = @_;
-
- my $buildargs = $self->associated_metaclass->find_method_by_name("BUILDARGS");
-
- if ( $args eq '@_'
- and ( !$buildargs or $buildargs->body == \&Moose::Object::BUILDARGS )
- ) {
-
- # This is the same logic as Moose::Object::BUILDARGS
- return sprintf( <<'EOF', $self->_inline_throw_error( q{'Single parameters to new() must be a HASH ref'}, 'data => $_[0]' ) );
-do {
- my $params;
- if ( scalar @_ == 1 ) {
- unless ( defined $_[0] && ref $_[0] eq 'HASH' ) {
- %s
- }
- $params = { %%{ $_[0] } };
- }
- elsif ( @_ %% 2 ) {
- Carp::carp(
- "The new() method for $class expects a hash reference or a key/value list."
- . " You passed an odd number of arguments" );
- $params = { @_, undef };
- }
- else {
- $params = {@_};
- }
- $params
-};
-EOF
- ;
- }
- else {
- return $class . "->BUILDARGS($args)";
- }
-}
-
-sub _generate_BUILDALL {
- my $self = shift;
- my @BUILD_calls;
- foreach my $method (reverse $self->associated_metaclass->find_all_methods_by_name('BUILD')) {
- push @BUILD_calls => '$instance->' . $method->{class} . '::BUILD($params)';
- }
- return join ";\n" => @BUILD_calls;
-}
-
-sub _generate_triggers {
- my $self = shift;
- my @trigger_calls;
- foreach my $i ( 0 .. $#{ $self->_attributes } ) {
- my $attr = $self->_attributes->[$i];
-
- next unless $attr->can('has_trigger') && $attr->has_trigger;
-
- my $init_arg = $attr->init_arg;
-
- next unless defined $init_arg;
-
- push @trigger_calls => '(exists $params->{\''
- . $init_arg
- . '\'}) && do {'
- . "\n "
- . '$attrs->['
- . $i
- . ']->trigger->('
- . '$instance, '
- . $attr->inline_get('$instance')
- . ', '
- . ');' . "\n}";
- }
-
- return join ";\n" => @trigger_calls;
-}
-
-sub _generate_slot_initializer {
- my $self = shift;
- my $index = shift;
-
- my $attr = $self->_attributes->[$index];
-
- my @source = ('## ' . $attr->name);
-
- my $is_moose = $attr->isa('Moose::Meta::Attribute'); # XXX FIXME
-
- if ($is_moose && defined($attr->init_arg) && $attr->is_required && !$attr->has_default && !$attr->has_builder) {
- push @source => ('(exists $params->{\'' . $attr->init_arg . '\'}) ' .
- '|| ' . $self->_inline_throw_error('"Attribute (' . quotemeta($attr->name) . ') is required"') .';');
- }
-
- if (($attr->has_default || $attr->has_builder) && !($is_moose && $attr->is_lazy)) {
-
- if ( defined( my $init_arg = $attr->init_arg ) ) {
- push @source => 'if (exists $params->{\'' . $init_arg . '\'}) {';
- push @source => ('my $val = $params->{\'' . $init_arg . '\'};');
- push @source => $self->_generate_type_constraint_and_coercion($attr, $index)
- if $is_moose;
- push @source => $self->_generate_slot_assignment($attr, '$val', $index);
- push @source => "} else {";
- }
- my $default;
- if ( $attr->has_default ) {
- $default = $self->_generate_default_value($attr, $index);
- }
- else {
- my $builder = $attr->builder;
- $default = '$instance->' . $builder;
- }
-
- push @source => '{'; # wrap this to avoid my $val overwrite warnings
- push @source => ('my $val = ' . $default . ';');
- push @source => $self->_generate_type_constraint_and_coercion($attr, $index)
- if $is_moose;
- push @source => $self->_generate_slot_assignment($attr, '$val', $index);
- push @source => '}'; # close - wrap this to avoid my $val overrite warnings
-
- push @source => "}" if defined $attr->init_arg;
- }
- elsif ( defined( my $init_arg = $attr->init_arg ) ) {
- push @source => '(exists $params->{\'' . $init_arg . '\'}) && do {';
-
- push @source => ('my $val = $params->{\'' . $init_arg . '\'};');
- if ($is_moose && $attr->has_type_constraint) {
- if ($attr->should_coerce && $attr->type_constraint->has_coercion) {
- push @source => $self->_generate_type_coercion(
- $attr,
- '$type_constraints[' . $index . ']',
- '$val',
- '$val'
- );
- }
- push @source => $self->_generate_type_constraint_check(
- $attr,
- '$type_constraint_bodies[' . $index . ']',
- '$type_constraints[' . $index . ']',
- '$val'
- );
- }
- push @source => $self->_generate_slot_assignment($attr, '$val', $index);
-
- push @source => "}";
- }
-
- return join "\n" => @source;
-}
-
-sub _generate_slot_assignment {
- my ($self, $attr, $value, $index) = @_;
-
- my $source;
-
- if ( $attr->has_initializer ) {
- return
- '$attrs->['
- . $index
- . ']->set_initial_value($instance, '
- . $value . ');';
- }
- else {
- return $attr->inline_set(
- '$instance',
- $value
- ) . ';';
- }
-
- return $source;
-}
-
-sub _generate_type_constraint_and_coercion {
- my ($self, $attr, $index) = @_;
-
- return unless $attr->has_type_constraint;
-
- my @source;
- if ($attr->should_coerce && $attr->type_constraint->has_coercion) {
- push @source => $self->_generate_type_coercion(
- $attr,
- '$type_constraints[' . $index . ']',
- '$val',
- '$val'
- );
- }
- push @source => $self->_generate_type_constraint_check(
- $attr,
- ('$type_constraint_bodies[' . $index . ']'),
- ('$type_constraints[' . $index . ']'),
- '$val'
- );
- return @source;
-}
-
-sub _generate_type_coercion {
- my ($self, $attr, $type_constraint_name, $value_name, $return_value_name) = @_;
- return ($return_value_name . ' = ' . $type_constraint_name . '->coerce(' . $value_name . ');');
-}
-
-sub _generate_type_constraint_check {
- my ($self, $attr, $type_constraint_cv, $type_constraint_obj, $value_name) = @_;
- return (
- $self->_inline_throw_error('"Attribute (' # FIXME add 'dad'
- . quotemeta( $attr->name )
- . ') does not pass the type constraint because: " . '
- . $type_constraint_obj . '->get_message(' . $value_name . ')')
- . "\n\t unless " . $type_constraint_cv . '->(' . $value_name . ');'
- );
+ return {
+ '$meta' => \$self,
+ '$attrs' => \$attrs,
+ '$defaults' => \$defaults,
+ '@type_constraints' => \@type_constraints,
+ '@type_constraint_bodies' => \@type_constraint_bodies,
+ };
}
1;
use Devel::GlobalDestruction ();
use Scalar::Util 'blessed', 'weaken';
-use Try::Tiny ();
+use Try::Tiny;
our $VERSION = '1.19';
$VERSION = eval $VERSION;
# requires some adaption on the part of
# the author, after all, nothing is free)
- my @DEMOLISH_methods = $self->associated_metaclass->find_all_methods_by_name('DEMOLISH');
-
- my $source;
- $source = 'sub {' . "\n";
- $source .= 'my $self = shift;' . "\n";
- $source .= 'return $self->Moose::Object::DESTROY(@_)' . "\n";
- $source .= ' if Scalar::Util::blessed($self) ne ';
- $source .= "'" . $self->associated_metaclass->name . "'";
- $source .= ';' . "\n";
-
- if ( @DEMOLISH_methods ) {
- $source .= 'local $?;' . "\n";
-
- $source .= 'my $in_global_destruction = Devel::GlobalDestruction::in_global_destruction;' . "\n";
-
- $source .= 'Try::Tiny::try {' . "\n";
-
- $source .= '$self->' . $_->{class} . '::DEMOLISH($in_global_destruction);' . "\n"
- for @DEMOLISH_methods;
-
- $source .= '}';
- $source .= q[ Try::Tiny::catch { no warnings 'misc'; die $_ };] . "\n";
- $source .= 'return;' . "\n";
+ my $class = $self->associated_metaclass->name;
+ my @source = (
+ 'sub {',
+ 'my $self = shift;',
+ 'return ' . $self->_generate_fallback_destructor('$self'),
+ 'if Scalar::Util::blessed($self) ne \'' . $class . '\';',
+ $self->_generate_DEMOLISHALL('$self'),
+ '}',
+ );
+ warn join("\n", @source) if $self->options->{debug};
+ my $code = try {
+ $self->_compile_code(source => \@source);
}
+ catch {
+ my $source = join("\n", @source);
+ $self->throw_error(
+ "Could not eval the destructor :\n\n$source\n\nbecause :\n\n$_",
+ error => $_,
+ data => $source,
+ );
+ };
- $source .= '}';
-
- warn $source if $self->options->{debug};
+ $self->{'body'} = $code;
+}
- my ( $code, $e ) = $self->_compile_code(
- environment => {},
- code => $source,
- );
+sub _generate_fallback_destructor {
+ my $self = shift;
+ my ($inv) = @_;
- $self->throw_error(
- "Could not eval the destructor :\n\n$source\n\nbecause :\n\n$e",
- error => $e, data => $source )
- if $e;
+ return $inv . '->Moose::Object::DESTROY(@_)';
+}
- $self->{'body'} = $code;
+sub _generate_DEMOLISHALL {
+ my $self = shift;
+ my ($inv) = @_;
+
+ my @methods = $self->associated_metaclass->find_all_methods_by_name('DEMOLISH');
+ return unless @methods;
+
+ return (
+ 'local $?;',
+ 'my $igd = Devel::GlobalDestruction::in_global_destruction;',
+ 'Try::Tiny::try {',
+ (map { $inv . '->' . $_->{class} . '::DEMOLISH($igd);' } @methods),
+ '}',
+ 'Try::Tiny::catch {',
+ 'no warnings \'misc\';',
+ 'die $_;',
+ '};',
+ 'return;',
+ );
}
default => 'Moose::Meta::Role::Application::ToInstance',
);
+$META->add_attribute(
+ 'applied_attribute_metaclass',
+ reader => 'applied_attribute_metaclass',
+ default => 'Moose::Meta::Attribute',
+);
+
# More or less copied from Moose::Meta::Class
sub initialize {
my $class = shift;
application_to_class_class
application_to_role_class
application_to_instance_class
+ applied_attribute_metaclass
);
}
keys %{$self->$accessor};
}
-sub reset_package_cache_flag { (shift)->{'_package_cache_flag'} = undef }
-sub update_package_cache_flag {
- my $self = shift;
- $self->{'_package_cache_flag'} = Class::MOP::check_package_cache_flag($self->name);
-}
-
-
sub _meta_method_class { 'Moose::Meta::Method::Meta' }
## ------------------------------------------------------------------
sub apply_attributes {
my ($self, $role, $class) = @_;
- my $attr_metaclass = $class->attribute_metaclass;
+ my $attr_metaclass = $role->applied_attribute_metaclass;
foreach my $attribute_name ($role->get_attribute_list) {
# it if it has one already
=over 4
-=item B<< coerce 'Name' => from 'OtherName' => via { ... } >>
+=item B<< coerce 'Name' => from 'OtherName' => via { ... } >>
This defines a coercion from one type to another. The C<Name> argument
is the type you are coercing I<to>.
+To define multiple coercions, supply more sets of from/via pairs:
+
+ coerce 'Name' =>
+ from 'OtherName' => via { ... },
+ from 'ThirdName' => via { ... };
+
=item B<from 'OtherName'>
This is just sugar for the type coercion construction syntax.
is( exception { $foo->type_constrained(10.5) }, undef, "Num type constraint for now.." );
# try to rebless, except it will fail due to Child's stricter type constraint
-like( exception { Child->meta->rebless_instance($foo) }, qr/^Attribute \(type_constrained\) does not pass the type constraint because\: Validation failed for 'Int' with value 10\.5/, '... this failed cause of type check' );
-like( exception { Child->meta->rebless_instance($bar) }, qr/^Attribute \(type_constrained\) does not pass the type constraint because\: Validation failed for 'Int' with value 5\.5/, '... this failed cause of type check' );
+like( exception { Child->meta->rebless_instance($foo) }, qr/^Attribute \(type_constrained\) does not pass the type constraint because\: Validation failed for 'Int' with value 10\.5/, '... this failed because of type check' );
+like( exception { Child->meta->rebless_instance($bar) }, qr/^Attribute \(type_constrained\) does not pass the type constraint because\: Validation failed for 'Int' with value 5\.5/, '... this failed because of type check' );
$foo->type_constrained(10);
$bar->type_constrained(5);
is($foo->lazy_classname, 'Parent', "lazy attribute was already initialized");
is($bar->lazy_classname, 'Child', "lazy attribute just now initialized");
-like( exception { $foo->type_constrained(10.5) }, qr/^Attribute \(type_constrained\) does not pass the type constraint because\: Validation failed for 'Int' with value 10\.5/, '... this failed cause of type check' );
+like( exception { $foo->type_constrained(10.5) }, qr/^Attribute \(type_constrained\) does not pass the type constraint because\: Validation failed for 'Int' with value 10\.5/, '... this failed because of type check' );
done_testing;
--- /dev/null
+#!/usr/bin/env perl
+use strict;
+use warnings;
+use Test::More;
+
+{
+ package Foo::Meta::Attribute;
+ use Moose::Role;
+}
+
+{
+ package Foo::Meta::Attribute2;
+ use Moose::Role;
+}
+
+{
+ package Foo::Role;
+ use Moose::Role;
+
+ has foo => (is => 'ro');
+}
+
+{
+ package Foo;
+ use Moose;
+ Moose::Util::MetaRole::apply_metaroles(
+ for => __PACKAGE__,
+ class_metaroles => { attribute => ['Foo::Meta::Attribute'] },
+ role_metaroles => { applied_attribute => ['Foo::Meta::Attribute2'] },
+ );
+ with 'Foo::Role';
+
+ has bar => (is => 'ro');
+}
+
+ok(Moose::Util::does_role(Foo->meta->get_attribute('bar'), 'Foo::Meta::Attribute'), "attrs defined in the class get the class metarole applied");
+ok(!Moose::Util::does_role(Foo->meta->get_attribute('bar'), 'Foo::Meta::Attribute2'), "attrs defined in the class don't get the role metarole applied");
+ok(!Moose::Util::does_role(Foo->meta->get_attribute('foo'), 'Foo::Meta::Attribute'), "attrs defined in the role don't get the metarole applied");
+ok(!Moose::Util::does_role(Foo->meta->get_attribute('foo'), 'Foo::Meta::Attribute'), "attrs defined in the role don't get the role metarole defined in the class applied");
+
+{
+ package Bar::Meta::Attribute;
+ use Moose::Role;
+}
+
+{
+ package Bar::Meta::Attribute2;
+ use Moose::Role;
+}
+
+{
+ package Bar::Role;
+ use Moose::Role;
+ Moose::Util::MetaRole::apply_metaroles(
+ for => __PACKAGE__,
+ class_metaroles => { attribute => ['Bar::Meta::Attribute'] },
+ role_metaroles => { applied_attribute => ['Bar::Meta::Attribute2'] },
+ );
+
+ has foo => (is => 'ro');
+}
+
+{
+ package Bar;
+ use Moose;
+ with 'Bar::Role';
+
+ has bar => (is => 'ro');
+}
+
+ok(!Moose::Util::does_role(Bar->meta->get_attribute('bar'), 'Bar::Meta::Attribute'), "attrs defined in the class don't get the class metarole from the role applied");
+ok(!Moose::Util::does_role(Bar->meta->get_attribute('bar'), 'Bar::Meta::Attribute2'), "attrs defined in the class don't get the role metarole applied");
+ok(Moose::Util::does_role(Bar->meta->get_attribute('foo'), 'Bar::Meta::Attribute2'), "attrs defined in the role get the role metarole applied");
+ok(!Moose::Util::does_role(Bar->meta->get_attribute('foo'), 'Bar::Meta::Attribute'), "attrs defined in the role don't get the class metarole applied");
+
+{
+ package Baz::Meta::Attribute;
+ use Moose::Role;
+}
+
+{
+ package Baz::Meta::Attribute2;
+ use Moose::Role;
+}
+
+{
+ package Baz::Role;
+ use Moose::Role;
+ Moose::Util::MetaRole::apply_metaroles(
+ for => __PACKAGE__,
+ class_metaroles => { attribute => ['Baz::Meta::Attribute'] },
+ role_metaroles => { applied_attribute => ['Baz::Meta::Attribute2'] },
+ );
+
+ has foo => (is => 'ro');
+}
+
+{
+ package Baz;
+ use Moose;
+ Moose::Util::MetaRole::apply_metaroles(
+ for => __PACKAGE__,
+ class_metaroles => { attribute => ['Baz::Meta::Attribute'] },
+ role_metaroles => { applied_attribute => ['Baz::Meta::Attribute2'] },
+ );
+ with 'Baz::Role';
+
+ has bar => (is => 'ro');
+}
+
+ok(Moose::Util::does_role(Baz->meta->get_attribute('bar'), 'Baz::Meta::Attribute'), "attrs defined in the class get the class metarole applied");
+ok(!Moose::Util::does_role(Baz->meta->get_attribute('bar'), 'Baz::Meta::Attribute2'), "attrs defined in the class don't get the role metarole applied");
+ok(Moose::Util::does_role(Baz->meta->get_attribute('foo'), 'Baz::Meta::Attribute2'), "attrs defined in the role get the role metarole applied");
+ok(!Moose::Util::does_role(Baz->meta->get_attribute('foo'), 'Baz::Meta::Attribute'), "attrs defined in the role don't get the class metarole applied");
+
+{
+ package Accessor::Modifying::Role;
+ use Moose::Role;
+
+ around _process_options => sub {
+ my $orig = shift;
+ my $self = shift;
+ my ($name, $params) = @_;
+ $self->$orig(@_);
+ $params->{reader} .= '_foo';
+ };
+}
+
+{
+ package Plain::Role;
+ use Moose::Role;
+
+ has foo => (
+ is => 'ro',
+ isa => 'Str',
+ );
+}
+
+{
+ package Class::With::Trait;
+ use Moose;
+ Moose::Util::MetaRole::apply_metaroles(
+ for => __PACKAGE__,
+ class_metaroles => {
+ attribute => ['Accessor::Modifying::Role'],
+ },
+ );
+ with 'Plain::Role';
+
+ has bar => (
+ is => 'ro',
+ isa => 'Str',
+ );
+}
+
+{
+ can_ok('Class::With::Trait', 'foo');
+ can_ok('Class::With::Trait', 'bar_foo');
+}
+
+{
+ package Role::With::Trait;
+ use Moose::Role;
+ Moose::Util::MetaRole::apply_metaroles(
+ for => __PACKAGE__,
+ role_metaroles => {
+ applied_attribute => ['Accessor::Modifying::Role'],
+ },
+ );
+ with 'Plain::Role';
+
+ has foo => (
+ is => 'ro',
+ isa => 'Str',
+ );
+
+ sub foo_test {
+ my $self = shift;
+ return $self->can('foo_foo');
+ }
+}
+
+{
+ package Class::With::Role::With::Trait;
+ use Moose;
+ with 'Role::With::Trait';
+
+ has bar => (
+ is => 'ro',
+ isa => 'Str',
+ );
+
+ sub bar_test {
+ my $self = shift;
+ return $self->can('bar');
+ }
+}
+
+{
+ can_ok('Class::With::Role::With::Trait', 'foo_foo');
+ can_ok('Class::With::Role::With::Trait', 'bar');
+}
+
+done_testing;
our $called = 0;
{
- package Foo::Trait::Constructor;
+ package Foo::Trait::Class;
use Moose::Role;
- around _generate_BUILDALL => sub {
+ around _inline_BUILDALL => sub {
my $orig = shift;
my $self = shift;
- return $self->$orig(@_) . '$::called++;';
+ return (
+ $self->$orig(@_),
+ '$::called++;'
+ );
}
}
Moose::Util::MetaRole::apply_metaroles(
for => __PACKAGE__,
class_metaroles => {
- constructor => ['Foo::Trait::Constructor'],
+ class => ['Foo::Trait::Class'],
}
);
}
Foo->new;
is($called, 1, "inlined constructor has trait modifications");
-ok(Foo->meta->constructor_class->meta->does_role('Foo::Trait::Constructor'),
- "class has correct constructor traits");
+ok(Foo->meta->meta->does_role('Foo::Trait::Class'),
+ "class has correct traits");
{
package Foo::Sub;
Foo::Sub->meta->make_immutable;
Foo::Sub->new;
-is($called, 1, "inherits constructor trait properly");
+is($called, 1, "inherits trait properly");
-ok(Foo::Sub->meta->constructor_class->meta->can('does_role')
-&& Foo::Sub->meta->constructor_class->meta->does_role('Foo::Trait::Constructor'),
- "subclass inherits constructor traits");
+ok(Foo::Sub->meta->meta->can('does_role')
+&& Foo::Sub->meta->meta->does_role('Foo::Trait::Class'),
+ "subclass inherits traits");
{
package Foo2::Role;
projects / gitmo/Moose.git / commitdiff