X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FDBIx%2FClass%2FSchema.pm;h=7527ddfc6d2ffd8ab4c789059eabf8e8d0b0efe3;hb=5c33c8beee177383b6c7913989b60629783dedf1;hp=76395aea3afabdf232182f9ecf888814233fec2c;hpb=93d7452f38b38b66d6d8282425a928873725f43e;p=dbsrgits%2FDBIx-Class.git diff --git a/lib/DBIx/Class/Schema.pm b/lib/DBIx/Class/Schema.pm index 76395ae..7527ddf 100644 --- a/lib/DBIx/Class/Schema.pm +++ b/lib/DBIx/Class/Schema.pm @@ -8,8 +8,10 @@ use base 'DBIx::Class'; use DBIx::Class::Carp; use Try::Tiny; use Scalar::Util qw/weaken blessed/; -use Sub::Name 'subname'; -use B 'svref_2object'; +use DBIx::Class::_Util qw( + refcount quote_sub scope_guard + is_exception dbic_internal_try +); use Devel::GlobalDestruction; use namespace::clean; @@ -109,11 +111,12 @@ are no matching Result classes like this: load_namespaces found ResultSet class $classname with no corresponding Result class -If a Result class is found to already have a ResultSet class set using -L to some other class, you will be warned like this: +If a ResultSource instance is found to already have a ResultSet class set +using L to some +other class, you will be warned like this: - We found ResultSet class '$rs_class' for '$result', but it seems - that you had already set '$result' to use '$rs_set' instead + We found ResultSet class '$rs_class' for '$result_class', but it seems + that you had already set '$result_class' to use '$rs_set' instead =head3 Examples @@ -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 { @@ -897,7 +900,6 @@ sub compose_namespace { local *Class::C3::reinitialize = sub { } if DBIx::Class::_ENV_::OLD_MRO; use warnings qw/redefine/; - no strict qw/refs/; foreach my $source_name ($self->sources) { my $orig_source = $self->source($source_name); @@ -919,11 +921,8 @@ sub compose_namespace { } } - foreach my $meth (qw/class source resultset/) { - no warnings 'redefine'; - *{"${target}::${meth}"} = subname "${target}::${meth}" => - sub { shift->schema->$meth(@_) }; - } + quote_sub "${target}::${_}" => "shift->schema->$_(\@_)" + for qw(class source resultset); } Class::C3->reinitialize() if DBIx::Class::_ENV_::OLD_MRO; @@ -1059,26 +1058,71 @@ 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" + ); + }; + + eval { + # 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; } - 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.' + 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] = $@ ); + + # 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 @@ -1122,8 +1166,8 @@ sub deploy { A convenient shortcut to C<< $self->storage->deployment_statements($self, @args) >>. -Returns the SQL statements used by L and -L. +Returns the statements used by L and +L. =cut @@ -1196,14 +1240,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 @@ -1217,19 +1259,17 @@ 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); } =head2 freeze -This doesn't actually do anything more than call L, it is just -provided here for symmetry. +This doesn't actually do anything beyond calling L, +it is just provided here for symmetry. =cut sub freeze { - require Storable; return Storable::nfreeze($_[1]); } @@ -1252,7 +1292,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); } @@ -1367,7 +1406,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} @@ -1392,6 +1431,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; @@ -1405,7 +1447,8 @@ sub DESTROY { # which will serve as a signal to not try doing anything else # however beware - on older perls the exception seems randomly untrappable # due to some weird race condition during thread joining :((( - if (ref $srcs->{$source_name} and svref_2object($srcs->{$source_name})->REFCNT > 1) { + 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); @@ -1418,6 +1461,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 { @@ -1474,13 +1522,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) { @@ -1488,7 +1535,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); } @@ -1496,12 +1543,8 @@ sub compose_connection { return $self; } - my $schema = $self->compose_namespace($target, $base); - { - no strict 'refs'; - my $name = join '::', $target, 'schema'; - *$name = subname $name, sub { $schema }; - } + my $schema = $self->compose_namespace($target, 'DBIx::Class::ResultSetProxy'); + quote_sub "${target}::schema", '$s', { '$s' => \$schema }; $schema->connection(@info); foreach my $source_name ($schema->sources) { @@ -1515,14 +1558,17 @@ sub compose_connection { return $schema; } -1; +=head1 FURTHER QUESTIONS? -=head1 AUTHOR AND CONTRIBUTORS +Check the list of L. -See L and L in DBIx::Class +=head1 COPYRIGHT AND LICENSE -=head1 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;