X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FDBIx%2FClass%2FSchema.pm;h=9961c08d9a9142f8fa32b2050151346cf5304653;hb=e570488ade8f327f47dd3318db3443a348d561d6;hp=17427054b227d48c8d5052096ad57ccc70639185;hpb=aff5e9c14f7ad7453a4a2a7d04dc4e85fa0d661c;p=dbsrgits%2FDBIx-Class-Historic.git diff --git a/lib/DBIx/Class/Schema.pm b/lib/DBIx/Class/Schema.pm index 1742705..9961c08 100644 --- a/lib/DBIx/Class/Schema.pm +++ b/lib/DBIx/Class/Schema.pm @@ -11,17 +11,21 @@ use Scalar::Util qw/weaken blessed/; use DBIx::Class::_Util qw( refcount quote_sub scope_guard is_exception dbic_internal_try + fail_on_internal_call emit_loud_diag ); use Devel::GlobalDestruction; use namespace::clean; -__PACKAGE__->mk_classdata('class_mappings' => {}); -__PACKAGE__->mk_classdata('source_registrations' => {}); -__PACKAGE__->mk_classdata('storage_type' => '::DBI'); -__PACKAGE__->mk_classdata('storage'); -__PACKAGE__->mk_classdata('exception_action'); -__PACKAGE__->mk_classdata('stacktrace' => $ENV{DBIC_TRACE} || 0); -__PACKAGE__->mk_classdata('default_resultset_attributes' => {}); +__PACKAGE__->mk_group_accessors( inherited => qw( storage exception_action ) ); +__PACKAGE__->mk_classaccessor('storage_type' => '::DBI'); +__PACKAGE__->mk_classaccessor('stacktrace' => $ENV{DBIC_TRACE} || 0); +__PACKAGE__->mk_classaccessor('default_resultset_attributes' => {}); + +# These two should have been private from the start but too late now +# Undocumented on purpose, hopefully it won't ever be necessary to +# screw with them +__PACKAGE__->mk_classaccessor('class_mappings' => {}); +__PACKAGE__->mk_classaccessor('source_registrations' => {}); =head1 NAME @@ -195,7 +199,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?: $_" @@ -426,6 +430,30 @@ both types of refs here in order to play nice with your Config::[class] or your choice. See L for an example of this. +=head2 default_resultset_attributes + +=over 4 + +=item Arguments: L<\%attrs|DBIx::Class::ResultSet/ATTRIBUTES> + +=item Return Value: L<\%attrs|DBIx::Class::ResultSet/ATTRIBUTES> + +=item Default value: None + +=back + +Like L stores a collection +of resultset attributes, to be used as defaults for B ResultSet +instance schema-wide. The same list of CAVEATS and WARNINGS applies, with +the extra downside of these defaults being practically inescapable: you will +B be able to derive a ResultSet instance with these attributes unset. + +Example: + + package My::Schema; + use base qw/DBIx::Class::Schema/; + __PACKAGE__->default_resultset_attributes( { software_limit => 1 } ); + =head2 exception_action =over 4 @@ -524,7 +552,10 @@ version, overload L instead. =cut -sub connect { shift->clone->connection(@_) } +sub connect { + DBIx::Class::_ENV_::ASSERT_NO_INTERNAL_INDIRECT_CALLS and fail_on_internal_call; + shift->clone->connection(@_); +} =head2 resultset @@ -584,21 +615,58 @@ source name. =cut sub source { - my $self = shift; + my ($self, $source_name) = @_; $self->throw_exception("source() expects a source name") - unless @_; + unless $source_name; - my $source_name = shift; + my $source_registrations; - my $sreg = $self->source_registrations; - return $sreg->{$source_name} if exists $sreg->{$source_name}; + my $rsrc = + ( $source_registrations = $self->source_registrations )->{$source_name} + || + # if we got here, they probably passed a full class name + $source_registrations->{ $self->class_mappings->{$source_name} || '' } + || + $self->throw_exception( "Can't find source for ${source_name}" ) + ; - # if we got here, they probably passed a full class name - my $mapped = $self->class_mappings->{$source_name}; - $self->throw_exception("Can't find source for ${source_name}") - unless $mapped && exists $sreg->{$mapped}; - return $sreg->{$mapped}; + # DO NOT REMOVE: + # We need to prevent alterations of pre-existing $@ due to where this call + # sits in the overall stack ( *unless* of course there is an actual error + # to report ). set_mro does alter $@ (and yes - it *can* throw an exception) + # We do not use local because set_mro *can* throw an actual exception + # We do not use a try/catch either, as on one hand it would slow things + # down for no reason (we would always rethrow), but also because adding *any* + # try/catch block below will segfault various threading tests on older perls + # ( which in itself is a FIXME but ENOTIMETODIG ) + my $old_dollarat = $@; + + no strict 'refs'; + mro::set_mro($_, 'c3') for + grep + { + # some pseudo-sources do not have a result/resultset yet + defined $_ + and + ( + ( + ${"${_}::__INITIAL_MRO_UPON_DBIC_LOAD__"} + ||= mro::get_mro($_) + ) + ne + 'c3' + ) + } + map + { length ref $_ ? ref $_ : $_ } + ( $rsrc, $rsrc->result_class, $rsrc->resultset_class ) + ; + + # DO NOT REMOVE - see comment above + $@ = $old_dollarat; + + $rsrc; } =head2 class @@ -768,6 +836,8 @@ those values. =cut sub populate { + DBIx::Class::_ENV_::ASSERT_NO_INTERNAL_INDIRECT_CALLS and fail_on_internal_call; + my ($self, $name, $data) = @_; my $rs = $self->resultset($name) or $self->throw_exception("'$name' is not a resultset"); @@ -781,13 +851,13 @@ sub populate { =item Arguments: @args -=item Return Value: $new_schema +=item Return Value: $self =back Similar to L except sets the storage object and connection -data in-place on the Schema class. You should probably be calling -L to get a proper Schema object instead. +data B on C<$self>. You should probably be calling +L to get a properly L Schema object instead. =head3 Overloading @@ -865,25 +935,6 @@ will produce the output =cut -# this might be oversimplified -# sub compose_namespace { -# my ($self, $target, $base) = @_; - -# my $schema = $self->clone; -# foreach my $source_name ($schema->sources) { -# my $source = $schema->source($source_name); -# my $target_class = "${target}::${source_name}"; -# $self->inject_base( -# $target_class => $source->result_class, ($base ? $base : ()) -# ); -# $source->result_class($target_class); -# $target_class->result_source_instance($source) -# if $target_class->can('result_source_instance'); -# $schema->register_source($source_name, $source); -# } -# return $schema; -# } - sub compose_namespace { my ($self, $target, $base) = @_; @@ -906,30 +957,45 @@ sub compose_namespace { 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 quote_sub "${target}::${_}" => "shift->schema->$_(\@_)" for qw(class source resultset); } 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; } +# LEGACY: The intra-call to this was removed in 66d9ef6b and then +# the sub was de-documented way later in 249963d4. No way to be sure +# nothing on darkpan is calling it directly, so keeping as-is sub setup_connection_class { my ($class, $target, @info) = @_; $class->inject_base($target => 'DBIx::Class::DB'); @@ -1028,13 +1094,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); @@ -1070,8 +1133,8 @@ sub throw_exception { my $guard = scope_guard { return if $guard_disarmed; - local $SIG{__WARN__}; - Carp::cluck(" + emit_loud_diag( emit_dups => 1, msg => " + !!! DBIx::Class INTERNAL PANIC !!! The exception_action() handler installed on '$self' @@ -1084,11 +1147,11 @@ anything for other software that might be affected by a similar problem. !!! FIX YOUR ERROR HANDLING !!! -This guard was activated beginning" +This guard was activated starting", ); }; - eval { + dbic_internal_try { # if it throws - good, we'll assign to @args in the end # if it doesn't - do different things depending on RV truthiness if( $act->(@args) ) { @@ -1109,14 +1172,13 @@ This guard was activated beginning" 1; } - - or - - # We call this to get the necessary warnings emitted and disregard the RV - # as it's definitely an exception if we got as far as this do{} block - is_exception( - $args[0] = $@ - ); + catch { + # We call this to get the necessary warnings emitted and disregard the RV + # as it's definitely an exception if we got as far as this catch{} block + is_exception( + $args[0] = $_ + ); + }; # Done guarding against https://github.com/PerlDancer/Dancer2/issues/1125 $guard_disarmed = 1; @@ -1336,13 +1398,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 @@ -1392,41 +1454,53 @@ has a source and you want to register an extra one. sub register_extra_source { shift->_register_source(@_, { extra => 1 }) } sub _register_source { - my ($self, $source_name, $source, $params) = @_; + my ($self, $source_name, $supplied_rsrc, $params) = @_; - $source = $source->new({ %$source, source_name => $source_name }); + my $derived_rsrc = $supplied_rsrc->clone({ + source_name => $source_name, + }); - $source->schema($self); - weaken $source->{schema} if ref($self); + # Do not move into the clone-hashref above: there are things + # on CPAN that do hook 'sub schema' + # https://metacpan.org/source/LSAUNDERS/DBIx-Class-Preview-1.000003/lib/DBIx/Class/ResultSource/Table/Previewed.pm#L9-38 + $derived_rsrc->schema($self); + + weaken $derived_rsrc->{schema} + if length ref($self); my %reg = %{$self->source_registrations}; - $reg{$source_name} = $source; + $reg{$source_name} = $derived_rsrc; $self->source_registrations(\%reg); - return $source if $params->{extra}; + return $derived_rsrc if $params->{extra}; - my $rs_class = $source->result_class; - if ($rs_class and my $rsrc = dbic_internal_try { $rs_class->result_source_instance } ) { + my( $result_class, $result_class_level_rsrc ); + if ( + $result_class = $derived_rsrc->result_class + and + # There are known cases where $rs_class is *ONLY* an inflator, without + # any hint of a rsrc (e.g. DBIx::Class::KiokuDB::EntryProxy) + $result_class_level_rsrc = dbic_internal_try { $result_class->result_source_instance } + ) { my %map = %{$self->class_mappings}; - if ( - exists $map{$rs_class} + + carp ( + "$result_class already had a registered source which was replaced by " + . 'this call. Perhaps you wanted register_extra_source(), though it is ' + . 'more likely you did something wrong.' + ) if ( + exists $map{$result_class} and - $map{$rs_class} ne $source_name + $map{$result_class} ne $source_name and - $rsrc ne $_[2] # orig_source - ) { - carp - "$rs_class already had a registered source which was replaced by this call. " - . 'Perhaps you wanted register_extra_source(), though it is more likely you did ' - . 'something wrong.' - ; - } + $result_class_level_rsrc != $supplied_rsrc + ); - $map{$rs_class} = $source_name; + $map{$result_class} = $source_name; $self->class_mappings(\%map); } - return $source; + $derived_rsrc; } my $global_phase_destroy; @@ -1448,7 +1522,8 @@ sub DESTROY { # however beware - on older perls the exception seems randomly untrappable # due to some weird race condition during thread joining :((( if (length ref $srcs->{$source_name} and refcount($srcs->{$source_name}) > 1) { - local $@; + local $SIG{__DIE__} if $SIG{__DIE__}; + local $@ if DBIx::Class::_ENV_::UNSTABLE_DOLLARAT; eval { $srcs->{$source_name}->schema($self); weaken $srcs->{$source_name}; @@ -1535,8 +1610,8 @@ sub compose_connection { my $source = $self->source($source_name); my $class = $source->result_class; $self->inject_base($class, 'DBIx::Class::ResultSetProxy'); - $class->mk_classdata(resultset_instance => $source->resultset); - $class->mk_classdata(class_resolver => $self); + $class->mk_classaccessor(resultset_instance => $source->resultset); + $class->mk_classaccessor(class_resolver => $self); } $self->connection(@info); return $self; @@ -1550,9 +1625,13 @@ sub compose_connection { my $source = $schema->source($source_name); my $class = $source->result_class; #warn "$source_name $class $source ".$source->storage; - $class->mk_classdata(result_source_instance => $source); - $class->mk_classdata(resultset_instance => $source->resultset); - $class->mk_classdata(class_resolver => $schema); + + $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); } return $schema; }