view release on metacpan or  search on metacpan

lib/UR/Object/Type/Initializer.pm  view on Meta::CPAN

            }
            Carp::croak($error);
        }
        $@ = $dollarat;
    }
    # UR::DataSource::File-backed classes don't have table_names, but for querying/saving to
    # work property, their properties still have to have column_name filled in
    if (($new_class{table_name} or ($the_data_source and ($the_data_source->initializer_should_create_column_name_for_class_properties())))
        and not exists($new_property{column_name})    # They didn't supply a column_name
        and not $new_property{is_transient}
        and not $new_property{is_delegated}
        and not $new_property{is_calculated}
        and not $new_property{is_legacy_eav}
    ) {
        $new_property{column_name} = $new_property{property_name};
        if ($the_data_source and $the_data_source->table_and_column_names_are_upper_case) {
            $new_property{column_name} = uc($new_property{column_name});
        }
    }

    if ($new_property{order_by} and not $new_property{is_many}) {
        die "Cannot use order_by except on is_many properties!";
    }

    if ($new_property{specify_by} and not $new_property{is_many}) {
        die "Cannot use specify_by except on is_many properties!";
    }

    if ($new_property{implied_by} and $new_property{implied_by} eq $property_name) {
        $class->warnings_message("New data has odd self-referential 'implied_by' on $class_name $property_name!");
        delete $new_property{implied_by};
    }

    return %new_property;
}


sub _make_minimal_class_from_normalized_class_description {
    my $class = shift;
    my $desc = shift;

    my $class_name = $desc->{class_name};
    unless ($class_name) {
        Carp::confess("No class name specified?");
    }

    my $meta_class_name = $desc->{meta_class_name};
    die unless $meta_class_name;
    if ($meta_class_name ne __PACKAGE__) {
        unless (
            $meta_class_name->isa(__PACKAGE__)
        ) {
            warn "Bogus meta class $meta_class_name doesn't inherit from UR::Object::Type?"
        }
    }

    # only do this when the classes match
    # when they do not match, the super-class has already called this by delegating to the correct subclass
    $class_name::VERSION = 2.0; # No BumpVersion

    my $self =  bless { id => $class_name, %$desc }, $meta_class_name;

    $UR::Context::all_objects_loaded->{$meta_class_name}{$class_name} = $self;
    my $full_name = join( '::', $class_name, '__meta__' );
    Sub::Install::reinstall_sub({
        into => $class_name,
        as   => '__meta__',
        code => Sub::Name::subname $full_name => sub {$self},
    });

    return $self;
}

sub _initialize_accessors_and_inheritance {
    my $self = shift;

    $self->initialize_direct_accessors;

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

    my @is = @{ $self->{is} };
    unless (@is) {
        @is = ('UR::ModuleBase')
    }
    eval "\@${class_name}::ISA = (" . join(',', map { "'$_'" } @is) . ")\n";
    Carp::croak("Can't initialize \@ISA for class_name '$class_name': $@\nMaybe the class_name or one of the parent classes are not valid class names") if $@;

    my $namespace_mro;
    my $namespace_name = $self->{namespace};
    if (
        !$bootstrapping
        && !$class_name->isa('UR::Namespace')
        && $namespace_name
        && $namespace_name->isa('UR::Namespace')
        && $namespace_name->can('get')
        && (my $namespace = $namespace_name->get())
    ) {
        $namespace_mro = $namespace->method_resolution_order;
    }

    if ($^V lt v5.9.5 && $namespace_mro && $namespace_mro eq 'c3') {
        warn "C3 method resolution order is not supported on Perl < 5.9.5. Reverting $namespace_name namespace to DFS.";
        my $namespace = $namespace_name->get();
        $namespace_mro = $namespace->method_resolution_order('dfs');
    }

    if ($^V ge v5.9.5 && $namespace_mro && mro::get_mro($class_name) ne $namespace_mro) {
        mro::set_mro($class_name, $namespace_mro);
    }

    return $self;
}

our %_init_subclasses_loaded;
sub subclasses_loaded {
    return @{ $_init_subclasses_loaded{shift->class_name}};
}

our %_inform_all_parent_classes_of_newly_loaded_subclass;
sub _inform_all_parent_classes_of_newly_loaded_subclass {
    my $self = shift;