X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FDBIx%2FClass%2FSchema.pm;h=17a8bbafca3b41c1aa89c141133d77afa6c9e075;hb=c356fcb1919c92e9f9b1dfe9fcc4c4cd33dc5ad6;hp=f19c7bcc046a23a12d4cacab0a3e1478e24165c7;hpb=7648acb5dd1f2f281ca84e2152efe314bcbf2c70;p=dbsrgits%2FDBIx-Class.git diff --git a/lib/DBIx/Class/Schema.pm b/lib/DBIx/Class/Schema.pm index f19c7bc..17a8bba 100644 --- a/lib/DBIx/Class/Schema.pm +++ b/lib/DBIx/Class/Schema.pm @@ -7,8 +7,9 @@ use base 'DBIx::Class'; use DBIx::Class::Carp; use Try::Tiny; -use Scalar::Util qw/weaken blessed/; +use Scalar::Util qw( weaken blessed refaddr ); use DBIx::Class::_Util qw( + false emit_loud_diag refdesc refcount quote_sub scope_guard is_exception dbic_internal_try fail_on_internal_call emit_loud_diag @@ -27,6 +28,12 @@ __PACKAGE__->mk_classaccessor('default_resultset_attributes' => {}); __PACKAGE__->mk_classaccessor('class_mappings' => {}); __PACKAGE__->mk_classaccessor('source_registrations' => {}); +__PACKAGE__->mk_group_accessors( component_class => 'schema_sanity_checker' ); +__PACKAGE__->schema_sanity_checker( + DBIx::Class::_ENV_::OLD_MRO ? false : + 'DBIx::Class::Schema::SanityChecker' +); + =head1 NAME DBIx::Class::Schema - composable schemas @@ -199,7 +206,7 @@ sub _ns_get_rsrc_instance { my $rs_class = ref ($_[0]) || $_[0]; return dbic_internal_try { - $rs_class->result_source_instance + $rs_class->result_source } catch { $me->throw_exception ( "Attempt to load_namespaces() class $rs_class failed - are you sure this is a real Result Class?: $_" @@ -237,10 +244,6 @@ sub load_namespaces { my @to_register; { - no warnings qw/redefine/; - local *Class::C3::reinitialize = sub { } if DBIx::Class::_ENV_::OLD_MRO; - use warnings qw/redefine/; - # ensure classes are loaded and attached in inheritance order for my $result_class (values %$results_by_source_name) { $class->ensure_class_loaded($result_class); @@ -294,8 +297,6 @@ sub load_namespaces { .'with no corresponding Result class'; } - Class::C3->reinitialize if DBIx::Class::_ENV_::OLD_MRO; - $class->register_class(@$_) for (@to_register); return; @@ -377,10 +378,6 @@ sub load_classes { my @to_register; { - no warnings qw/redefine/; - local *Class::C3::reinitialize = sub { } if DBIx::Class::_ENV_::OLD_MRO; - use warnings qw/redefine/; - foreach my $prefix (keys %comps_for) { foreach my $comp (@{$comps_for{$prefix}||[]}) { my $comp_class = "${prefix}::${comp}"; @@ -397,7 +394,6 @@ sub load_classes { } } } - Class::C3->reinitialize if DBIx::Class::_ENV_::OLD_MRO; foreach my $to (@to_register) { $class->register_class(@$to); @@ -454,6 +450,42 @@ Example: use base qw/DBIx::Class::Schema/; __PACKAGE__->default_resultset_attributes( { software_limit => 1 } ); +=head2 schema_sanity_checker + +=over 4 + +=item Arguments: L provider + +=item Return Value: L provider + +=item Default value: L + +=back + +On every call to L if the value of this attribute evaluates to +true, DBIC will invoke +C<< L<$schema_sanity_checker|/schema_sanity_checker>->L($schema) >> +before returning. The return value of this invocation is ignored. + +B to +L this +feature was introduced. Blindly disabling the checker on existing projects +B after upgrade to C<< DBIC >= v0.082900 >>. + +Example: + + package My::Schema; + use base qw/DBIx::Class::Schema/; + __PACKAGE__->schema_sanity_checker('My::Schema::SanityChecker'); + + # or to disable all checks: + __PACKAGE__->schema_sanity_checker(''); + +Note: setting the value to C B have the desired effect, +due to an implementation detail of L inherited +accessors. In order to disable any and all checks you must set this +attribute to an empty string as shown in the second example above. + =head2 exception_action =over 4 @@ -552,7 +584,7 @@ version, overload L instead. =cut -sub connect { +sub connect :DBIC_method_is_indirect_sugar { DBIx::Class::_ENV_::ASSERT_NO_INTERNAL_INDIRECT_CALLS and fail_on_internal_call; shift->clone->connection(@_); } @@ -835,7 +867,7 @@ those values. =cut -sub populate { +sub populate :DBIC_method_is_indirect_sugar { DBIx::Class::_ENV_::ASSERT_NO_INTERNAL_INDIRECT_CALLS and fail_on_internal_call; my ($self, $name, $data) = @_; @@ -859,12 +891,17 @@ Similar to L except sets the storage object and connection data B on C<$self>. You should probably be calling L to get a properly L Schema object instead. +If the accessor L returns a true value C<$checker>, +the following call will take place before return: +C<< L<$checker|/schema_sanity_checker>->L)|DBIx::Class::Schema::SanityChecker/perform_schema_sanity_checks> >> + =head3 Overloading Overload C to change the behaviour of C. =cut +my $default_off_stderr_blurb_emitted; sub connection { my ($self, @info) = @_; return $self if !@info && $self->storage; @@ -888,7 +925,53 @@ sub connection { my $storage = $storage_class->new( $self => $args||{} ); $storage->connect_info(\@info); $self->storage($storage); - return $self; + + +### +### Begin 5.8 "you have not selected a checker" warning +### + # We can not blanket-enable this on 5.8 - it is just too expensive for + # day to day execution. We also can't just go silent - there are genuine + # regressions ( due to core changes) for which this is the only line of + # defense. So instead we whine on STDERR that folks need to do something + # + # Beyond suboptimal, but given the constraints the best we can do :( + # + # This should stay around for at least 3~4 years + # + DBIx::Class::_ENV_::OLD_MRO + and + ! $default_off_stderr_blurb_emitted + and + length ref $self->schema_sanity_checker + and + length ref __PACKAGE__->schema_sanity_checker + and + ( + refaddr( $self->schema_sanity_checker ) + == + refaddr( __PACKAGE__->schema_sanity_checker ) + ) + and + emit_loud_diag( + msg => sprintf( + "Sanity checks for schema %s are disabled on this perl $]: " + . '*THIS IS POTENTIALLY VERY DANGEROUS*. You are strongly urged to ' + . "read http://is.gd/dbic_sancheck_5_008 before proceeding\n", + ( defined( blessed $self ) ? refdesc $self : "'$self'" ) + )) + and + $default_off_stderr_blurb_emitted = 1; +### +### End 5.8 "you have not selected a checker" warning +### + + + if( my $checker = $self->schema_sanity_checker ) { + $checker->perform_schema_sanity_checks($self); + } + + $self; } sub _normalize_storage_type { @@ -947,29 +1030,18 @@ sub compose_namespace { #$schema->class_mappings({}); { - no warnings qw/redefine/; - local *Class::C3::reinitialize = sub { } if DBIx::Class::_ENV_::OLD_MRO; - use warnings qw/redefine/; - foreach my $source_name ($self->sources) { my $orig_source = $self->source($source_name); my $target_class = "${target}::${source_name}"; $self->inject_base($target_class, $orig_source->result_class, ($base || ()) ); - # register_source examines result_class, and then returns us a clone - my $new_source = $schema->register_source($source_name, bless - { %$orig_source, result_class => $target_class }, - ref $orig_source, + $schema->register_source( + $source_name, + $orig_source->clone( + result_class => $target_class + ), ); - - if ($target_class->can('result_source_instance')) { - # give the class a schema-less source copy - $target_class->result_source_instance( bless - { %$new_source, schema => ref $new_source->{schema} || $new_source->{schema} }, - ref $new_source, - ); - } } # Legacy stuff, not inserting INDIRECT assertions @@ -977,7 +1049,26 @@ sub compose_namespace { for qw(class source resultset); } - Class::C3->reinitialize() if DBIx::Class::_ENV_::OLD_MRO; + # needed to cover the newly installed stuff via quote_sub above + Class::C3->reinitialize if DBIx::Class::_ENV_::OLD_MRO; + + # Give each composed class yet another *schema-less* source copy + # this is used for the freeze/thaw cycle + # + # This is not covered by any tests directly, but is indirectly exercised + # in t/cdbi/sweet/08pager by re-setting the schema on an existing object + # FIXME - there is likely a much cheaper way to take care of this + for my $source_name ($self->sources) { + + my $target_class = "${target}::${source_name}"; + + $target_class->result_source_instance( + $self->source($source_name)->clone( + result_class => $target_class, + schema => ( ref $schema || $schema ), + ) + ); + } return $schema; } @@ -1083,13 +1174,10 @@ sub _copy_state_from { $self->class_mappings({ %{$from->class_mappings} }); $self->source_registrations({ %{$from->source_registrations} }); - foreach my $source_name ($from->sources) { - my $source = $from->source($source_name); - my $new = $source->new($source); - # we use extra here as we want to leave the class_mappings as they are - # but overwrite the source_registrations entry with the new source - $self->register_extra_source($source_name => $new); - } + # we use extra here as we want to leave the class_mappings as they are + # but overwrite the source_registrations entry with the new source + $self->register_extra_source( $_ => $from->source($_) ) + for $from->sources; if ($from->storage) { $self->storage($from->storage); @@ -1390,13 +1478,13 @@ file). You may also need it to register classes at runtime. Registers a class which isa DBIx::Class::ResultSourceProxy. Equivalent to calling: - $schema->register_source($source_name, $component_class->result_source_instance); + $schema->register_source($source_name, $component_class->result_source); =cut sub register_class { my ($self, $source_name, $to_register) = @_; - $self->register_source($source_name => $to_register->result_source_instance); + $self->register_source($source_name => $to_register->result_source); } =head2 register_source @@ -1448,8 +1536,7 @@ sub register_extra_source { shift->_register_source(@_, { extra => 1 }) } sub _register_source { my ($self, $source_name, $supplied_rsrc, $params) = @_; - my $derived_rsrc = $supplied_rsrc->new({ - %$supplied_rsrc, + my $derived_rsrc = $supplied_rsrc->clone({ source_name => $source_name, }); @@ -1459,7 +1546,7 @@ sub _register_source { $derived_rsrc->schema($self); weaken $derived_rsrc->{schema} - if length ref($self); + if length( my $schema_class = ref($self) ); my %reg = %{$self->source_registrations}; $reg{$source_name} = $derived_rsrc; @@ -1491,6 +1578,44 @@ sub _register_source { $map{$result_class} = $source_name; $self->class_mappings(\%map); + + + my $schema_class_level_rsrc; + if ( + # we are called on a schema instance, not on the class + length $schema_class + + and + + # the schema class also has a registration with the same name + $schema_class_level_rsrc = dbic_internal_try { $schema_class->source($source_name) } + + and + + # what we are registering on the schema instance *IS* derived + # from the class-level (top) rsrc... + ( grep { $_ == $derived_rsrc } $result_class_level_rsrc->__derived_instances ) + + and + + # ... while the schema-class-level has stale-markers + keys %{ $schema_class_level_rsrc->{__metadata_divergencies} || {} } + ) { + my $msg = + "The ResultSource instance you just registered on '$self' as " + . "'$source_name' seems to have no relation to $schema_class->" + . "source('$source_name') which in turn is marked stale (likely due " + . "to recent $result_class->... direct class calls). This is almost " + . "always a mistake: perhaps you forgot a cycle of " + . "$schema_class->unregister_source( '$source_name' ) / " + . "$schema_class->register_class( '$source_name' => '$result_class' )" + ; + + DBIx::Class::_ENV_::ASSERT_NO_ERRONEOUS_METAINSTANCE_USE + ? emit_loud_diag( msg => $msg, confess => 1 ) + : carp_unique($msg) + ; + } } $derived_rsrc; @@ -1613,12 +1738,19 @@ sub compose_connection { my $schema = $self->compose_namespace($target, 'DBIx::Class::ResultSetProxy'); quote_sub "${target}::schema", '$s', { '$s' => \$schema }; + # needed to cover the newly installed stuff via quote_sub above + Class::C3->reinitialize if DBIx::Class::_ENV_::OLD_MRO; + $schema->connection(@info); foreach my $source_name ($schema->sources) { my $source = $schema->source($source_name); my $class = $source->result_class; #warn "$source_name $class $source ".$source->storage; - $class->mk_classaccessor(result_source_instance => $source); + + $class->mk_group_accessors( inherited => [ result_source_instance => '_result_source' ] ); + # explicit set-call, avoid mro update lag + $class->set_inherited( result_source_instance => $source ); + $class->mk_classaccessor(resultset_instance => $source->resultset); $class->mk_classaccessor(class_resolver => $schema); }