X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FDBIx%2FClass%2FSchema.pm;h=d5a8f35832bc3ca135f1f3b2b0b35cdc8b1360ef;hb=f064a2abb15858bb39a141ad50391d4191988d2c;hp=7b5ae64ed721efb40e027171fcfb0fce5f47ae2e;hpb=e1d9e578b84f642cb24181d0403b15ab78a9fda7;p=dbsrgits%2FDBIx-Class.git diff --git a/lib/DBIx/Class/Schema.pm b/lib/DBIx/Class/Schema.pm index 7b5ae64..d5a8f35 100644 --- a/lib/DBIx/Class/Schema.pm +++ b/lib/DBIx/Class/Schema.pm @@ -8,17 +8,24 @@ use base 'DBIx::Class'; use DBIx::Class::Carp; use Try::Tiny; use Scalar::Util qw/weaken blessed/; -use DBIx::Class::_Util qw(refcount quote_sub); +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 @@ -191,7 +198,7 @@ sub _ns_get_rsrc_instance { my $me = shift; my $rs_class = ref ($_[0]) || $_[0]; - return try { + return dbic_internal_try { $rs_class->result_source_instance } catch { $me->throw_exception ( @@ -423,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 @@ -521,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 @@ -581,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_registrations; - my $source_name = shift; + 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}" ) + ; + + # 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 ) + ; - my $sreg = $self->source_registrations; - return $sreg->{$source_name} if exists $sreg->{$source_name}; + # DO NOT REMOVE - see comment above + $@ = $old_dollarat; - # 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}; + $rsrc; } =head2 class @@ -765,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"); @@ -778,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 @@ -803,7 +876,7 @@ sub connection { $storage_class =~ s/^::/DBIx::Class::Storage::/; - try { + dbic_internal_try { $self->ensure_class_loaded ($storage_class); } catch { @@ -862,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) = @_; @@ -903,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'); @@ -1025,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); @@ -1055,26 +1121,70 @@ default behavior will provide a detailed stack trace. =cut sub throw_exception { - my $self = shift; + my ($self, @args) = @_; + + if ( + ! DBIx::Class::_Util::in_internal_try() + and + my $act = $self->exception_action + ) { + + my $guard_disarmed; - if (my $act = $self->exception_action) { - if ($act->(@_)) { - DBIx::Class::Exception->throw( + my $guard = scope_guard { + return if $guard_disarmed; + emit_loud_diag( emit_dups => 1, msg => " + + !!! DBIx::Class INTERNAL PANIC !!! + +The exception_action() handler installed on '$self' +aborted the stacktrace below via a longjmp (either via Return::Multilevel or +plain goto, or Scope::Upper or something equally nefarious). There currently +is nothing safe DBIx::Class can do, aside from displaying this error. A future +version ( 0.082900, when available ) will reduce the cases in which the +handler is invoked, but this is neither a complete solution, nor can it do +anything for other software that might be affected by a similar problem. + + !!! FIX YOUR ERROR HANDLING !!! + +This guard was activated starting", + ); + }; + + 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) ) { + $args[0] = ( "Invocation of the exception_action handler installed on $self did *not*" .' result in an exception. DBIx::Class is unable to function without a reliable' - .' exception mechanism, ensure that exception_action does not hide exceptions' - ." (original error: $_[0])" - ); + .' exception mechanism, ensure your exception_action does not hide exceptions' + ." (original error: $args[0])" + ); + } + else { + carp_unique ( + "The exception_action handler installed on $self returned false instead" + .' of throwing an exception. This behavior has been deprecated, adjust your' + .' handler to always rethrow the supplied error' + ); + } + + 1; } + 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] = $_ + ); + }; - carp_unique ( - "The exception_action handler installed on $self returned false instead" - .' of throwing an exception. This behavior has been deprecated, adjust your' - .' handler to always rethrow the supplied error.' - ); + # Done guarding against https://github.com/PerlDancer/Dancer2/issues/1125 + $guard_disarmed = 1; } - DBIx::Class::Exception->throw($_[0], $self->stacktrace); + DBIx::Class::Exception->throw( $args[0], $self->stacktrace ); } =head2 deploy @@ -1192,14 +1302,12 @@ format. sub ddl_filename { my ($self, $type, $version, $dir, $preversion) = @_; - require File::Spec; - $version = "$preversion-$version" if $preversion; my $class = blessed($self) || $self; $class =~ s/::/-/g; - return File::Spec->catfile($dir, "$class-$version-$type.sql"); + return "$dir/$class-$version-$type.sql"; } =head2 thaw @@ -1346,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, + }); + + # 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); - $source->schema($self); - weaken $source->{schema} if ref($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 = 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; @@ -1402,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}; @@ -1414,6 +1535,11 @@ sub DESTROY { last; } } + + # Dummy NEXTSTATE ensuring the all temporaries on the stack are garbage + # collected before leaving this scope. Depending on the code above, this + # may very well be just a preventive measure guarding future modifications + undef; } sub _unregister_source { @@ -1470,7 +1596,7 @@ sub compose_connection { carp_once "compose_connection deprecated as of 0.08000" unless $INC{"DBIx/Class/CDBICompat.pm"}; - try { + dbic_internal_try { require DBIx::Class::ResultSetProxy; } catch { @@ -1484,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; @@ -1499,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; }