X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FDBIx%2FClass%2FSchema.pm;h=f8179fb65ce7b4399e821869e62132640cd2d60b;hb=7704dbc93be76967fd8b051a3f6b1df32a2467a3;hp=dca80c893169466decb0de2b44a00f7fa98ca0c3;hpb=5529838f7afff91467ef2664087999ab222da48d;p=dbsrgits%2FDBIx-Class.git diff --git a/lib/DBIx/Class/Schema.pm b/lib/DBIx/Class/Schema.pm index dca80c8..f8179fb 100644 --- a/lib/DBIx/Class/Schema.pm +++ b/lib/DBIx/Class/Schema.pm @@ -8,7 +8,10 @@ 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 +); use Devel::GlobalDestruction; use namespace::clean; @@ -191,7 +194,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 ( @@ -803,7 +806,7 @@ sub connection { $storage_class =~ s/^::/DBIx::Class::Storage::/; - try { + dbic_internal_try { $self->ensure_class_loaded ($storage_class); } catch { @@ -1055,26 +1058,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; + + my $guard = scope_guard { + return if $guard_disarmed; + local $SIG{__WARN__}; + Carp::cluck(" + !!! 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 !!! - if (my $act = $self->exception_action) { - if ($act->(@_)) { - DBIx::Class::Exception->throw( +This guard was activated beginning" + ); + }; + + 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 +1239,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 @@ -1213,7 +1258,6 @@ reference to any schema, so are rather useless. sub thaw { my ($self, $obj) = @_; local $DBIx::Class::ResultSourceHandle::thaw_schema = $self; - require Storable; return Storable::thaw($obj); } @@ -1225,7 +1269,6 @@ it is just provided here for symmetry. =cut sub freeze { - require Storable; return Storable::nfreeze($_[1]); } @@ -1248,7 +1291,6 @@ objects so their references to the schema object sub dclone { my ($self, $obj) = @_; local $DBIx::Class::ResultSourceHandle::thaw_schema = $self; - require Storable; return Storable::dclone($obj); } @@ -1363,7 +1405,7 @@ sub _register_source { return $source if $params->{extra}; my $rs_class = $source->result_class; - if ($rs_class and my $rsrc = try { $rs_class->result_source_instance } ) { + if ($rs_class and my $rsrc = dbic_internal_try { $rs_class->result_source_instance } ) { my %map = %{$self->class_mappings}; if ( exists $map{$rs_class} @@ -1388,6 +1430,9 @@ sub _register_source { my $global_phase_destroy; sub DESTROY { + ### NO detected_reinvoked_destructor check + ### This code very much relies on being called multuple times + return if $global_phase_destroy ||= in_global_destruction; my $self = shift; @@ -1402,6 +1447,7 @@ 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 $SIG{__DIE__} if $SIG{__DIE__}; local $@; eval { $srcs->{$source_name}->schema($self); @@ -1414,6 +1460,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,13 +1521,12 @@ sub compose_connection { carp_once "compose_connection deprecated as of 0.08000" unless $INC{"DBIx/Class/CDBICompat.pm"}; - my $base = 'DBIx::Class::ResultSetProxy'; - try { - eval "require ${base};" + dbic_internal_try { + require DBIx::Class::ResultSetProxy; } catch { $self->throw_exception - ("No arguments to load_classes and couldn't load ${base} ($_)") + ("No arguments to load_classes and couldn't load DBIx::Class::ResultSetProxy ($_)") }; if ($self eq $target) { @@ -1484,7 +1534,7 @@ sub compose_connection { foreach my $source_name ($self->sources) { my $source = $self->source($source_name); my $class = $source->result_class; - $self->inject_base($class, $base); + $self->inject_base($class, 'DBIx::Class::ResultSetProxy'); $class->mk_classdata(resultset_instance => $source->resultset); $class->mk_classdata(class_resolver => $self); } @@ -1492,7 +1542,7 @@ sub compose_connection { return $self; } - my $schema = $self->compose_namespace($target, $base); + my $schema = $self->compose_namespace($target, 'DBIx::Class::ResultSetProxy'); quote_sub "${target}::schema", '$s', { '$s' => \$schema }; $schema->connection(@info); @@ -1507,14 +1557,17 @@ sub compose_connection { return $schema; } -1; - -=head1 AUTHOR AND CONTRIBUTORS +=head1 FURTHER QUESTIONS? -See L and L in DBIx::Class +Check the list of L. -=head1 LICENSE +=head1 COPYRIGHT AND LICENSE -You may distribute this code under the same terms as Perl itself. +This module is free software L +by the L. You can +redistribute it and/or modify it under the same terms as the +L. =cut + +1;