File Coverage

lib/UR/Role/Prototype.pm

Criterion	Covered	Total	%
statement	538	560	96.0
branch	100	128	78.1
condition	27	50	54.0
subroutine	93	95	97.8
pod	5	6	83.3
total	763	839	90.9

package UR::Role::Prototype;

use strict;
use warnings;

use UR;
use UR::Object::Type::InternalAPI;
use UR::Util;
use UR::AttributeHandlers;

use Sub::Name qw();
use Sub::Install qw();
use List::MoreUtils qw(any);
use Carp;
our @CARP_NOT = qw(UR::Object::Type);

our $VERSION = "0.46"; # UR $VERSION;;

UR::Object::Type->define(
    class_name => 'UR::Role::Prototype',
    doc => 'Object representing a role',
    id_by => 'role_name',
    has => [
        id_by       => { is => 'ARRAY', doc => 'List of ID properties and their definitions' },
        role_name   => { is => 'Text', doc => 'Package name identifying the role' },
        class_names => { is => 'Text', is_many => 1, doc => 'Class names composing this role' },
        methods     => { is => 'HASH', doc => 'Map of method names and coderefs', default => {} },
        overloads   => { is => 'HASH', doc => 'Map of overload keys and coderefs', default => {} },
        has         => { is => 'ARRAY', doc => 'List of properties and their definitions' },
        roles       => { is => 'ARRAY', doc => 'List of other role names composed into this role', default => [] },
        requires    => { is => 'ARRAY', doc => 'List of properties required of consuming classes', default => [] },
        attributes_have => { is => 'HASH', doc => 'Meta-attributes for properites' },
        excludes    => { is => 'ARRAY', doc => 'List of Role names that cannot compose with this role', default => [] },
        method_modifiers => { is => 'UR::Role::MethodModifier',
                              is_many => 1,
                              doc => q(List of 'before', 'after' and 'around' method modifiers),
                              reverse_as => 'role'
                            },
        map { $_ => _get_property_desc_from_ur_object_type($_) }
                                meta_properties_to_compose_into_classes(),
    ],
    is_transactional => 0,
);

sub property_data {
    my($self, $property_name) = @_;
    return $self->has->{$property_name};
}

sub has_property_names {
    my $self = shift;
    return keys %{ $self->has };
}

sub id_by_property_names {
    my $self = shift;
    return @{ $self->id_by };
}

sub method_names {
    my $self = shift;
    return keys %{ $self->methods };
}

sub meta_properties_to_compose_into_classes {
    return qw( is_abstract is_final is_singleton doc
               composite_id_separator id_generator valid_signals
               subclassify_by subclass_description_preprocessor sub_classification_method_name
               sub_classification_meta_class_name
               schema_name data_source_id table_name select_hint join_hint );
}

sub define {
    my $class = shift;
    my $desc = $class->_normalize_role_description(@_);

    unless ($desc->{role_name}) {
        Carp::croak(q('role_name' is a required parameter for defining a role));
    }

    my $methods = _introspect_methods($desc->{role_name});
    my $overloads = _introspect_overloads($desc->{role_name});

    my $extra = delete $desc->{extra};
    my $role = UR::Role::Prototype->__define__(%$desc, methods => $methods, overloads => $overloads);

    if ($extra and %$extra) {
        $role->UR::Object::Type::_apply_extra_attrs_to_class_or_role($extra);
    }

    $role->_inject_instance_constructor_into_namespace();

    return $role;
}

our @ROLE_DESCRIPTION_KEY_MAPPINGS = (
    @UR::Object::Type::CLASS_DESCRIPTION_KEY_MAPPINGS_COMMON_TO_CLASSES_AND_ROLES,
    [ role_name             => qw// ],
    [ methods               => qw// ],
    [ requires              => qw// ],
    [ excludes              => qw// ],
);

sub _normalize_role_description {
    my $class = shift;
    my $old_role = { @_ };

    my $role_name = delete $old_role->{role_name};

    my $new_role = {
        role_name => $role_name,
        has => {},
        attributes_have => {},
        UR::Object::Type::_canonicalize_class_params($old_role, \@ROLE_DESCRIPTION_KEY_MAPPINGS),
    };

    # The above call to _canonicalize_class_params removed recognized keys.  Anything
    # left over wasn't recognized
    $new_role->{extra} = $old_role;

    foreach my $key (qw( requires excludes ) ) {
        unless (UR::Util::ensure_arrayref($new_role, $key)) {
            Carp::croak("The '$key' metadata for role $role_name must be an arrayref");
        }
    }

    # UR::Object::Type::_normalize_class_description_impl() copies these over before
    # processing the properties.  We need to, too
    @$old_role{'has', 'attributes_have'} = @$new_role{'has','attributes_have'};
    @$new_role{'has','attributes_have'} = ( {}, {} );
    UR::Object::Type::_massage_field_into_arrayref($new_role, 'id_by');
    UR::Object::Type::_normalize_id_property_data($old_role, $new_role);
    UR::Object::Type::_process_class_definition_property_keys($old_role, $new_role);
    _complete_property_descriptions($new_role);

    return $new_role;
}

sub _complete_property_descriptions {
    my $role_desc = shift;

    # stole from UR::Object::Type::_normalize_class_description_impl()
    my $properties = $role_desc->{has};
    foreach my $property_name ( keys %$properties ) {
        my $old_property = $properties->{$property_name};
        my %new_property = UR::Object::Type->_normalize_property_description1($property_name, $old_property, $role_desc);
        delete $new_property{class_name};  # above normalizer fills this in as undef
        $properties->{$property_name} = \%new_property;
    }
}

my %property_definition_key_to_method_name = (
    is => 'data_type',
    len => 'data_length',
);

sub _get_property_desc_from_ur_object_type {
    my $property_name = shift;

    my $prop_meta = UR::Object::Property->get(class_name => 'UR::Object::Type', property_name => $property_name);
    Carp::croak("Couldn't get UR::Object::Type property meta for $property_name") unless $prop_meta;

    # These properties' definition key is the same as the method name
    my %definition = map { $_ => $prop_meta->$_ }
                     grep { defined $prop_meta->$_ }
                     qw( is_many is_optional is_transient is_mutable default_value doc );

    # These have a translation
    while(my($key, $method) = each(%property_definition_key_to_method_name)) {
        $definition{$key} = $prop_meta->$method;
    }

    # For any UR::Object::Type properties that are required or have a default value,
    # those don't apply to Roles
    $definition{is_optional} = 1;
    delete $definition{default_value};

    return \%definition;
}

{
    my @overload_ops;
    sub _all_overload_ops {
        @overload_ops = map { split /\s+/ } values(%overload::ops) unless @overload_ops;
        @overload_ops;
    }
}

my @DONT_EXPORT_THESE_SUBS_TO_CLASSES = qw(__import__ FETCH_CODE_ATTRIBUTES MODIFY_CODE_ATTRIBUTES MODIFY_SCALAR_ATTRIBUTES before after around);
sub _introspect_methods {
    my $role_name = shift;

    my $subs = UR::Util::coderefs_for_package($role_name);
    delete @$subs{@DONT_EXPORT_THESE_SUBS_TO_CLASSES};  # don't allow __import__ to be exported to a class's namespace
    delete @$subs{ map { "($_" } ( _all_overload_ops, ')', '(' ) };
    return $subs;
}

sub _introspect_overloads {
    my $role_name = shift;

    return {} unless overload::Overloaded($role_name);

    my %overloads;
    my $stash = do {
        no strict 'refs';
        \%{$role_name . '::'};
    };
    foreach my $op ( _all_overload_ops ) {
        my $op_key = $op eq 'fallback' ? ')' : $op;
        my $overloaded = $stash->{'(' . $op_key};

        if ($overloaded) {
            my $subref = *{$overloaded}{CODE};
            $overloads{$op} = $subref eq \&overload::nil
                                ? ${*{$overloaded}{SCALAR}} # overridden with string method name
                                : $subref; # overridden with a subref
        }
    }
    return \%overloads;
}

# Called by UR::Object::Type::Initializer::compose_roles to apply a role name
# to a partially constructed class description
sub _apply_roles_to_class_desc {
    my($class, $desc) = @_;
    if (ref($class) or ref($desc) ne 'HASH') {
        Carp::croak('_apply_roles_to_class_desc() must be called as a class method on a basic class description');
    }

    _validate_class_method_overrides_consumed_roles($desc);
    return unless ($desc->{roles} and @{ $desc->{roles} });
    my @role_objs = _role_prototypes_with_params_for_class_desc($desc);

    _validate_role_exclusions($desc, @role_objs);
    _validate_role_requirements($desc, @role_objs);
    _validate_class_desc_overrides($desc, @role_objs);

    my $id_property_names_to_add = _collect_id_property_names_from_roles($desc, @role_objs);
    my $properties_to_add = _collect_properties_from_roles($desc, @role_objs);
    my $meta_properties_to_add = _collect_meta_properties_from_roles($desc, @role_objs);
    my $overloads_to_add = _collect_overloads_from_roles($desc, @role_objs);
    my $method_modifiers_to_add = _collect_method_modifiers_from_roles($desc, @role_objs);

    _save_role_instances_to_class_desc($desc, @role_objs);
    _assert_all_role_params_are_bound_to_values($desc, @role_objs);
    do { $_->prototype->add_class_name($desc->{class_name}) } foreach @role_objs;

    UR::Role::Param->replace_unbound_params_in_struct_with_values(
            [ $id_property_names_to_add, $properties_to_add, $meta_properties_to_add, $overloads_to_add ],
            @role_objs);

    _import_methods_from_roles_into_namespace($desc->{class_name}, \@role_objs);
    _apply_overloads_to_namespace($desc->{class_name}, $overloads_to_add);
    _apply_method_modifiers_to_namespace($desc, $method_modifiers_to_add);

    _merge_role_meta_properties_into_class_desc($desc, $meta_properties_to_add);
    _merge_role_id_property_names_into_class_desc($desc, $id_property_names_to_add);
    _merge_role_properties_into_class_desc($desc, $properties_to_add);
}

sub _save_role_instances_to_class_desc {
    my($desc, @role_prototypes) = @_;

    my $class_name = $desc->{class_name};
    my @instances = map { $_->instantiate_role_instance($class_name) }
                    @role_prototypes;
    $desc->{roles} = \@instances;
}

sub _assert_all_role_params_are_bound_to_values {
    my($desc, @role_instances) = @_;

    foreach my $instance ( @role_instances ) {
        my $role_name = $instance->role_name;
        my %expected_params = map { $_ => 1 }
                              UR::Role::Param->param_names_for_role($role_name);
        my $got_params = $instance->role_params;
        if (my @missing = grep { ! exists($got_params->{$_}) } keys %expected_params) {
            Carp::croak("Role $role_name expects values for these params: ",join(', ', @missing));
        }
        if (my @extra = grep { ! exists($expected_params{$_}) } keys %$got_params) {
            Carp::croak("Role $role_name does not recognize these params: ",join(', ', @extra));
        }
    }
}


sub _merge_role_meta_properties_into_class_desc {
    my($desc, $meta_properties_to_add) = @_;

    my $valid_signals = delete $meta_properties_to_add->{valid_signals};
    my @meta_prop_names = keys %$meta_properties_to_add;
    @$desc{@meta_prop_names} = @$meta_properties_to_add{@meta_prop_names};
    if ($valid_signals) {
        push @{$desc->{valid_signals}}, @$valid_signals;
    };
}

sub _merge_role_properties_into_class_desc {
    my($desc, $properties_to_add) = @_;

    my @property_names = keys %$properties_to_add;
     @{$desc->{has}}{@property_names} = @$properties_to_add{@property_names};
}

sub _merge_role_id_property_names_into_class_desc {
    my($desc, $id_properties_to_add) = @_;

    push @{$desc->{id_by}}, @$id_properties_to_add;
}

sub _role_prototypes_with_params_for_class_desc {
    my $desc = shift;

    my @role_prototypes;
    foreach my $role_name ( @{ $desc->{roles} } ) {
        my $role;
        my $exception = do {
            local $@;
            $role = eval { $role_name->__role__ };
            $@;
        };
        unless ($role) {
            my $class_name = $desc->{class_name};
            Carp::croak("Cannot apply role $role_name to class $class_name: $exception");
        }
        push @role_prototypes, $role;
    }
    return @role_prototypes;
}

sub _collect_id_property_names_from_roles {
    my($desc, @role_objs) = @_;

    my %class_id_by_properties = map { $_ => 1 } @{ $desc->{id_by} };
    my %class_property_is_id_by = map { $_ => $class_id_by_properties{$_} }
                                  keys %{ $desc->{has} };

    my @property_names_to_add;
    foreach my $role ( @role_objs ) {
        my @role_id_property_names = $role->id_by_property_names;

        my @conflict = grep { exists($class_property_is_id_by{$_}) and ! $class_property_is_id_by{$_} }
                       @role_id_property_names;
        if (@conflict) {
            Carp::croak(sprintf(q(Cannot compose role %s: Property '%s' was declared as a normal property in class %s, but as an ID property in the role),
                                $role->role_name,
                                join(q(', '), @conflict),
                                $desc->{class_name},
                        ));
        }
        push @property_names_to_add, @role_id_property_names;
    }
    return \@property_names_to_add;
}

sub _collect_properties_from_roles {
    my($desc, @role_objs) = @_;

    my $properties_from_class = $desc->{has};

    my(%properties_to_add, %source_for_properties_to_add);
    foreach my $role ( @role_objs ) {
        my @role_property_names = $role->has_property_names;
        foreach my $property_name ( @role_property_names ) {
            my $prop_definition = $role->property_data($property_name);
            if (my $conflict = $source_for_properties_to_add{$property_name}) {
                Carp::croak(sprintf(q(Cannot compose role %s: Property '%s' conflicts with property in role %s),
                                    $role->role_name, $property_name, $conflict));
            }

            $source_for_properties_to_add{$property_name} = $role->role_name;

            next if exists $properties_from_class->{$property_name};

            $properties_to_add{$property_name} = $prop_definition;
        }
    }
    return UR::Util::deep_copy(\%properties_to_add);
}

sub _collect_overloads_from_roles {
    my($desc, @role_objs) = @_;

    my $overloads_from_class = _introspect_overloads($desc->{class_name});

    my(%overloads_to_add, %source_for_overloads_to_add);
    my $fallback_validator = _create_fallback_validator();

    foreach my $role ( @role_objs ) {
        my $role_name = $role->role_name;
        my $overloads_this_role = $role->overloads;

        $fallback_validator->($role_name, $overloads_this_role->{fallback});
        while( my($op, $impl) = each(%$overloads_this_role)) {
            next if ($op eq 'fallback');
            if (my $conflict = $source_for_overloads_to_add{$op}) {
                Carp::croak("Cannot compose role $role_name: Overload '$op' conflicts with overload in role $conflict");
            }
            $source_for_overloads_to_add{$op} = $role_name;

            next if exists $overloads_from_class->{$op};

            $overloads_to_add{$op} = $impl;
        }
    }

    my $fallback = $fallback_validator->();
    $overloads_to_add{fallback} = $fallback if defined $fallback;
    return \%overloads_to_add;
}

sub _collect_method_modifiers_from_roles {
    my($desc, @role_objs) = @_;

    my $class_name = $desc->{class_name};
    my @all_modifiers = map { $_->method_modifiers } @role_objs;

    my $isa = join('::', $class_name, 'ISA');
    no strict 'refs';
    local @$isa = (@$isa, @{$desc->{is}});
    use strict 'refs';

    foreach my $mod ( @all_modifiers ) {
        unless ($class_name->can($mod->name)) {
            my $role_name = $mod->role->role_name;
            my $type = $mod->type;
            my $subname = $mod->name;
            Carp::croak(qq(Cannot compose role $role_name: Cannot apply '$type' method modifier: Method "$subname" not found via class $class_name));
        }
    }
    return \@all_modifiers;
}

sub _create_fallback_validator {
    my($fallback, $fallback_set_in);

    return sub {
        unless (@_) {
            # no args, return current value
            return $fallback;
        }

        my($role_name, $value) = @_;
        if (defined($value) and !defined($fallback)) {
            $fallback = $value;
            $fallback_set_in = $role_name;
            return 1;
        }
        return 1 unless (defined($fallback) and defined ($value));
        return 1 unless ($fallback xor $value);

        Carp::croak(sprintf(q(Cannot compose role %s: fallback value '%s' conflicts with fallback value '%s' in role %s),
                                $role_name,
                                $value ? $value : defined($value) ? 'FALSE' : 'UNDEF',
                                $fallback ? $fallback : defined($fallback) ? 'FALSE' : 'UNDEF',
                                $fallback_set_in));
    };
}


sub _collect_meta_properties_from_roles {
    my($desc, @role_objs) = @_;

    my(%meta_properties_to_add, %source_for_meta_properties_to_add);
    foreach my $role ( @role_objs ) {
        foreach my $meta_prop_name ( $role->meta_properties_to_compose_into_classes ) {
            next if (defined $desc->{$meta_prop_name} and $meta_prop_name ne 'valid_signals');
            next unless defined $role->$meta_prop_name;

            if ($meta_prop_name ne 'valid_signals') {
                if (exists $meta_properties_to_add{$meta_prop_name}) {
                    Carp::croak(sprintf(q(Cannot compose role %s: Meta property '%s' conflicts with meta property from role %s),
                                        $role->role_name,
                                        $meta_prop_name,
                                        $source_for_meta_properties_to_add{$meta_prop_name}));
                }
                $meta_properties_to_add{$meta_prop_name} = $role->$meta_prop_name;
                $source_for_meta_properties_to_add{$meta_prop_name} = $role->role_name;
            } else {
                $meta_properties_to_add{valid_signals} ||= [];
                push @{ $meta_properties_to_add{valid_signals} }, @{ $role->valid_signals };
            }
        }
    }
    return UR::Util::deep_copy(\%meta_properties_to_add);
}

sub _validate_role_requirements {
    my($desc, @role_objs) = @_;

    my $class_name = $desc->{class_name};
    my %found_properties_and_methods = map { $_ => 1 } keys %{ $desc->{has} };

    foreach my $role ( @role_objs ) {
        foreach my $requirement ( @{ $role->requires } ) {
            unless ($found_properties_and_methods{ $requirement }
                        ||= _class_desc_lineage_has_method_or_property($desc, $requirement))
            {
                my $role_name = $role->role_name;
                Carp::croak("Cannot compose role $role_name: missing required property or method '$requirement'");
            }
        }

        # Properties and methods from this role can satisfy requirements for later roles
        foreach my $name ( $role->has_property_names, $role->method_names ) {
            $found_properties_and_methods{$name} = 1;
        }
    }

    return 1;
}

sub _validate_role_exclusions {
    my($desc, @role_objs) = @_;

    my %role_names = map { $_ => $_ } @{ $desc->{roles} };
    foreach my $role ( @role_objs ) {

        my @conflicts = grep { defined }
                            @role_names{ @{ $role->excludes } };
        if (@conflicts) {
            my $class_name = $desc->{class_name};
            my $plural = @conflicts > 1 ? 's' : '';
            Carp::croak(sprintf('Cannot compose role%s %s into class %s: Role %s excludes %s',
                                $plural,
                                join(', ', @conflicts),
                                $desc->{class_name},
                                $role->role_name,
                                $plural ? 'them' : 'it'));
        }
    }
    return 1;
}

sub _validate_class_method_overrides_consumed_roles {
    my $desc = shift;

    my $class_name = $desc->{class_name};
    my %this_class_role_names = $desc->{roles}
                                ? map { ref($_) ? ($_->role_name => 1) : ($_ => 1) }
                                    @{$desc->{roles}}
                                : ();
    my $this_class_methods = UR::Util::coderefs_for_package($class_name);
    while (my($method_name, $subref) = each %$this_class_methods) {
        my @overrides = UR::AttributeHandlers::get_overrides_for_coderef($subref);
        next unless (@overrides);

        my @missing_role_names = grep { ! exists $this_class_role_names{$_} }
                                 @overrides;
        if (@missing_role_names) {
            Carp::croak("Class method '$method_name' declares Overrides for roles the class does not consume: "
                        . join(', ', @missing_role_names));
        }
    }
    return 1;
}

sub _validate_class_desc_overrides {
    my($desc, @roles) = @_;

    my $class_name = $desc->{class_name};
    my %this_class_methods = map { %{ UR::Util::coderefs_for_package($_) } }
                                (@{$desc->{is}}, $class_name);

    my %overridden_methods_by_role;
    foreach my $method_name ( keys %this_class_methods ) {
        if (my @role_names = UR::AttributeHandlers::get_overrides_for_coderef($this_class_methods{$method_name})) {
            foreach my $role_name ( @role_names ) {
                $overridden_methods_by_role{$role_name} ||= [];
                push @{$overridden_methods_by_role{$role_name}}, $method_name;
            }
        }
    }

    foreach my $role ( @roles ) {
        my $role_name = $role->role_name;
        my $this_role_methods = $role->methods;
        my @this_role_method_names = keys( %$this_role_methods );

        my %method_is_overridden;
        my @conflict_methods = grep { ! ($method_is_overridden{$_} ||= _coderef_overrides_package($this_class_methods{$_}, $role_name)) }
                               grep { exists $this_class_methods{$_} }
                                   @this_role_method_names;
        if (@conflict_methods) {
            my $plural = scalar(@conflict_methods) > 1 ? 's' : '';
            my $conflicts = scalar(@conflict_methods) > 1 ? 'conflict' : 'conflicts';

            my %conflicting_sources;
            CONFLICTING_METHOD_NAME:
            foreach my $conflicting_method_name ( @conflict_methods ) {
                foreach my $source_class_name ( $class_name, @{$desc->{is}} ) {
                    if ($source_class_name->can($conflicting_method_name)) {
                        $conflicting_sources{$conflicting_method_name} = $source_class_name;
                        next CONFLICTING_METHOD_NAME;
                    }
                }
                $conflicting_sources{$conflicting_method_name} = '';
            }
            Carp::croak("Cannot compose role $role_name: "
                        . "Method name${plural} $conflicts with class $class_name:\n"
                        . join("\n", map { sprintf("\t%s (from %s)\n", $_, $conflicting_sources{$_}) }
                                        keys %conflicting_sources)
                        . "Did you forget to add the 'Overrides' attribute?");
        }

        my @missing_methods = grep { ! exists $this_role_methods->{$_} and ! exists $role->has->{$_} }
                              @{$overridden_methods_by_role{$role_name}};
        if (@missing_methods) {
            my $plural = scalar(@missing_methods) > 1 ? 's' : '';
            my $method_list = join(q(', '), @missing_methods);
            Carp::croak("Cannot compose role $role_name: "
                        . "Class method${plural} '$method_list' declares it Overrides non-existant method in the role.");
        }
    }

    return 1;
}

sub _class_desc_lineage_has_method_or_property {
    my($desc, $requirement) = @_;

    my $class_name = $desc->{class_name};
    if (my $can = $class_name->can($requirement)) {
        return $can;
    }

    my @is = @{ $desc->{is} };
    my %seen;
    while(my $parent = shift @is) {
        next if $seen{$parent}++;

        if (my $can = $parent->can($requirement)) {
            return $can;
        }

        my $parent_meta = $parent->__meta__;
        if (my $prop_meta = $parent_meta->property($requirement)) {
            return $prop_meta;
        }
    }
    return;
}

sub _import_methods_from_roles_into_namespace {
    my($class_name, $roles) = @_;

    my $this_class_methods = UR::Util::coderefs_for_package($class_name);

    my(%all_imported_methods, %method_sources);
    foreach my $role ( @$roles ) {
        my $this_role_methods = $role->methods;
        my @this_role_method_names = keys( %$this_role_methods );

        my @conflicting = grep { ! exists($this_class_methods->{$_}) }  # not a conflict if the class overrides
                          grep { exists $all_imported_methods{$_} }
                          @this_role_method_names;

        if (@conflicting) {
            my $plural = scalar(@conflicting) > 1 ? 's' : '';
            my $conflicts = scalar(@conflicting) > 1 ? 'conflict' : 'conflicts';
            Carp::croak('Cannot compose role ' . $role->role_name
                        . ": method${plural} $conflicts with those defined in other roles\n\t"
                        . join("\n\t", join('::', map { ( $method_sources{$_}, $_ ) } @conflicting)));
        }

        @method_sources{ @this_role_method_names } = ($role->role_name) x @this_role_method_names;
        @all_imported_methods{ @this_role_method_names } = @$this_role_methods{ @this_role_method_names };
    }

    delete @all_imported_methods{ keys %$this_class_methods };  # Don't import roles' methods already defined on the class
    foreach my $name ( keys %all_imported_methods ) {
        Sub::Install::install_sub({
            code => $all_imported_methods{$name},
            as => $name,
            into => $class_name,
        });
    }
}

sub _coderef_overrides_package {
    my($coderef, $package) = @_;

    my @overrides = UR::AttributeHandlers::get_overrides_for_coderef($coderef);
    return any { $_ eq $package } @overrides;
}

sub _apply_overloads_to_namespace {
    my($class_name, $overloads) = @_;

    my(%cooked_overloads);
    while( my($op, $impl) = each %$overloads) {
        $cooked_overloads{$op} = ref $impl
                                    ? sprintf(q($overloads->{'%s'}), $op)
                                    : qq('$impl');
    }

    my $string = "package $class_name;\n"
                 . 'use overload '
                 . join(",\n\t", map { sprintf(q('%s' => %s), $_, $cooked_overloads{$_}) } keys %cooked_overloads)
                 . ';';

    my $exception;
    do {
        local $@;
        eval $string;
        $exception = $@;
    };

    if ($exception) {
        Carp::croak("Failed to apply overloads to package $class_name: $exception");
    }
    return 1;
}

sub _apply_method_modifiers_to_namespace {
    my($desc, $modifiers_list) = @_;

    my $class_name = $desc->{class_name};

    my $isa = join('::', $class_name, 'ISA');
    no strict 'refs';
    local @$isa = (@$isa, @{$desc->{is}});
    use strict 'refs';

    foreach my $mod ( @$modifiers_list ) {
        $mod->apply_to_package($class_name);
    }
    1;
}

sub _define_role {
    my($role_name, $func, @params) = @_;

    if (defined($func) and $func eq "role" and @params > 1 and $role_name ne "UR::Role") {
        my @role_params;
        if (@params == 2 and ref($params[1]) eq 'HASH') {
            @role_params = %{ $params[1] };
        }
        elsif (@params == 2 and ref($params[1]) eq 'ARRAY') {
            @role_params = @{ $params[1] };
        }
        else {
            @role_params = @params[1..$#params];
        }
        my $role = UR::Role->define(role_name => $role_name, @role_params);
        unless ($role) {
            Carp::croak "error defining role $role_name!";
        }
        return sub { $role_name };
    } else {
        return;
    }
}

sub _inject_instance_constructor_into_namespace {
    my $self = shift;

    my $package = $self->role_name;
    my $full_name = join('::', $package, 'create');
    my $sub = Sub::Name::subname $full_name => sub {
        my($class, %params) = @_;
        return UR::Role::PrototypeWithParams->create(prototype => $self, role_params => \%params);
    };
    Sub::Install::reinstall_sub({
        into => $package,
        as => 'create',
        code => $sub,
    });

    Sub::Install::reinstall_sub({
        into => $package,
        as => '__role__',
        code => sub { $package->create() },
    });
}

1;

__END__