X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FMoose%2FUtil.pm;h=466e2aa737913c316c8d7de4252adef41489b654;hb=c14746bc8269ab593798469dc204aa0d8f72f7ee;hp=904ecd4f7ad47a756b95276f88c879d6766b6a0f;hpb=9a64184804a377cab8f7871932e4166cdbf4090e;p=gitmo%2FMoose.git diff --git a/lib/Moose/Util.pm b/lib/Moose/Util.pm index 904ecd4..466e2aa 100644 --- a/lib/Moose/Util.pm +++ b/lib/Moose/Util.pm @@ -1,25 +1,122 @@ package Moose::Util; -use Exporter qw/import/; -use Scalar::Util qw/blessed/; - use strict; use warnings; -our $VERSION = '0.01'; +use Sub::Exporter; +use Scalar::Util 'blessed'; +use Carp 'confess'; +use Class::MOP (); + +our $VERSION = '0.03'; +our $AUTHORITY = 'cpan:STEVAN'; + +my @exports = qw[ + find_meta + does_role + search_class_by_role + apply_all_roles + get_all_init_args + get_all_attribute_values +]; + +Sub::Exporter::setup_exporter({ + exports => \@exports, + groups => { all => \@exports } +}); + +## some utils for the utils ... + +sub find_meta { + return unless $_[0]; + return Class::MOP::get_metaclass_by_name(blessed($_[0]) || $_[0]); +} + +## the functions ... -our $AUTHORITY = 'cpan:BERLE'; +sub does_role { + my ($class_or_obj, $role) = @_; + + my $meta = find_meta($class_or_obj); + + return unless defined $meta; + + return 1 if $meta->does_role($role); + return; +} -our @EXPORT_OK = qw/can_role/; +sub search_class_by_role { + my ($class_or_obj, $role_name) = @_; + + my $meta = find_meta($class_or_obj); -sub can_role { - my ($class,$does) = @_; + return unless defined $meta; + + foreach my $class ($meta->class_precedence_list) { + + my $_meta = find_meta($class); + + next unless defined $_meta; + + foreach my $role (@{ $_meta->roles || [] }) { + return $class if $role->name eq $role_name; + } + } + + return; +} - return ((!ref $class && eval { $class->isa ('UNIVERSAL') }) || Scalar::Util::blessed ($class)) - && $class->can ('does') - && $class->does ($does); +sub apply_all_roles { + my $applicant = shift; + + confess "Must specify at least one role to apply to $applicant" unless @_; + + my $roles = Data::OptList::mkopt([ @_ ]); + + #use Data::Dumper; + #warn Dumper $roles; + + my $meta = (blessed $applicant ? $applicant : find_meta($applicant)); + + Class::MOP::load_class($_->[0]) for @$roles; + + ($_->[0]->can('meta') && $_->[0]->meta->isa('Moose::Meta::Role')) + || confess "You can only consume roles, " . $_->[0] . " is not a Moose role" + foreach @$roles; + + if (scalar @$roles == 1) { + my ($role, $params) = @{$roles->[0]}; + $role->meta->apply($meta, (defined $params ? %$params : ())); + } + else { + Moose::Meta::Role->combine( + @$roles + )->apply($meta); + } } +# instance deconstruction ... + +sub get_all_attribute_values { + my ($class, $instance) = @_; + return +{ + map { $_->name => $_->get_value($instance) } + grep { $_->has_value($instance) } + $class->compute_all_applicable_attributes + }; +} + +sub get_all_init_args { + my ($class, $instance) = @_; + return +{ + map { $_->init_arg => $_->get_value($instance) } + grep { $_->has_value($instance) } + grep { defined($_->init_arg) } + $class->compute_all_applicable_attributes + }; +} + + 1; __END__ @@ -28,25 +125,76 @@ __END__ =head1 NAME -Moose::Util - Moose utilities +Moose::Util - Utilities for working with Moose classes =head1 SYNOPSIS - use Moose::Util qw/can_role/; + use Moose::Util qw/find_meta does_role search_class_by_role/; + + my $meta = find_meta($object) || die "No metaclass found"; - if (can_role ($object,'rolename')) { - print "The object can do rolename!\n"; + if (does_role($object, $role)) { + print "The object can do $role!\n"; } -=head1 FUNCTIONS + my $class = search_class_by_role($object, 'FooRole'); + print "Nearest class with 'FooRole' is $class\n"; + +=head1 DESCRIPTION + +This is a set of utility functions to help working with Moose classes. This +is an experimental module, and it's not 100% clear what purpose it will serve. +That said, ideas, suggestions and contributions to this collection are most +welcome. See the L section below for a list of ideas for possible +functions to write. + +=head1 EXPORTED FUNCTIONS =over 4 -=item can_role +=item B - can_role ($object,$rolename); +This will attempt to locate a metaclass for the given C<$class_or_obj> +and return it. -Returns true if $object can do the role $rolename. +=item B + +Returns true if C<$class_or_obj> can do the role C<$role_name>. + +=item B + +Returns first class in precedence list that consumed C<$role_name>. + +=item B + +Given an C<$applicant> (which can somehow be turned into either a +metaclass or a metarole) and a list of C<@roles> this will do the +right thing to apply the C<@roles> to the C<$applicant>. This is +actually used internally by both L and L, and the +C<@roles> will be pre-processed through L +to allow for the additional arguments to be passed. + +=item B + +Returns the values of the C<$instance>'s fields keyed by the attribute names. + +=item B + +Returns a hash reference where the keys are all the attributes' Cs +and the values are the instance's fields. Attributes without an C +will be skipped. + +=back + +=head1 TODO + +Here is a list of possible functions to write + +=over 4 + +=item discovering original method from modified method + +=item search for origin class of a method or attribute =back @@ -60,9 +208,15 @@ to cpan-RT. Anders Nor Berle Edebolaz@gmail.comE +B + +Robert (phaylon) Sedlacek + +Stevan Little + =head1 COPYRIGHT AND LICENSE -Copyright 2007 by Infinity Interactive, Inc. +Copyright 2007-2008 by Infinity Interactive, Inc. L