Ensure proper behavior when quoting is *disabled* (wraps up 08ac7648)

[dbsrgits/DBIx-Class.git] / lib / DBIx / Class / Storage / DBI.pm

diff --git a/lib/DBIx/Class/Storage/DBI.pm b/lib/DBIx/Class/Storage/DBI.pm
index 0e579e9..4c815f0 100644 (file)
--- a/lib/DBIx/Class/Storage/DBI.pm
+++ b/lib/DBIx/Class/Storage/DBI.pm
@@ -10,11 +10,11 @@ use mro 'c3';
 use DBIx::Class::Carp;
 use Scalar::Util qw/refaddr weaken reftype blessed/;
 use List::Util qw/first/;
-use Sub::Name 'subname';
 use Context::Preserve 'preserve_context';
 use Try::Tiny;
 use Data::Compare (); # no imports!!! guard against insane architecture
-use DBIx::Class::_Util qw(is_plain_value is_literal_value);
+use SQL::Abstract qw(is_plain_value is_literal_value);
+use DBIx::Class::_Util qw(quote_sub perlstring);
 use namespace::clean;
 
 # default cursor class, overridable in connect_info attributes
@@ -119,9 +119,11 @@ for my $meth (keys %$storage_accessor_idx, qw(
   my $orig = __PACKAGE__->can ($meth)
     or die "$meth is not a ::Storage::DBI method!";
 
-  no strict 'refs';
-  no warnings 'redefine';
-  *{__PACKAGE__ ."::$meth"} = subname $meth => sub {
+  my $is_getter = $storage_accessor_idx->{$meth} ? 0 : 1;
+
+  quote_sub
+    __PACKAGE__ ."::$meth", sprintf( <<'EOC', $is_getter, perlstring $meth ), { '$orig' => \$orig };
+
     if (
       # only fire when invoked on an instance, a valid class-based invocation
       # would e.g. be setting a default for an inherited accessor
@@ -133,7 +135,7 @@ for my $meth (keys %$storage_accessor_idx, qw(
         and
       # if this is a known *setter* - just set it, no need to connect
       # and determine the driver
-      ! ( $storage_accessor_idx->{$meth} and @_ > 1 )
+      ( %1$s or @_ <= 1 )
         and
       # Only try to determine stuff if we have *something* that either is or can
       # provide a DSN. Allows for bare $schema's generated with a plain ->connect()
@@ -142,16 +144,15 @@ for my $meth (keys %$storage_accessor_idx, qw(
     ) {
       $_[0]->_determine_driver;
 
-      # This for some reason crashes and burns on perl 5.8.1
-      # IFF the method ends up throwing an exception
-      #goto $_[0]->can ($meth);
+      # work around http://rt.perl.org/rt3/Public/Bug/Display.html?id=35878
+      goto $_[0]->can(%2$s) unless DBIx::Class::_ENV_::BROKEN_GOTO;
 
-      my $cref = $_[0]->can ($meth);
+      my $cref = $_[0]->can(%2$s);
       goto $cref;
     }
 
     goto $orig;
-  };
+EOC
 }
 
 =head1 NAME
@@ -1633,17 +1634,13 @@ sub _exec_txn_rollback {
   shift->_dbh->rollback;
 }
 
-# generate some identical methods
-for my $meth (qw/svp_begin svp_release svp_rollback/) {
-  no strict qw/refs/;
-  *{__PACKAGE__ ."::$meth"} = subname $meth => sub {
-    my $self = shift;
-    $self->_verify_pid unless DBIx::Class::_ENV_::BROKEN_FORK;
-    $self->throw_exception("Unable to $meth() on a disconnected storage")
-      unless $self->_dbh;
-    $self->next::method(@_);
-  };
-}
+# generate the DBI-specific stubs, which then fallback to ::Storage proper
+quote_sub __PACKAGE__ . "::$_" => sprintf (<<'EOS', $_) for qw(svp_begin svp_release svp_rollback);
+  $_[0]->_verify_pid unless DBIx::Class::_ENV_::BROKEN_FORK;
+  $_[0]->throw_exception('Unable to %s() on a disconnected storage')
+    unless $_[0]->_dbh;
+  shift->next::method(@_);
+EOS
 
 # This used to be the top-half of _execute.  It was split out to make it
 #  easier to override in NoBindVars without duping the rest.  It takes up
@@ -2472,7 +2469,7 @@ sub _select_args {
     # are happy (this includes MySQL in strict_mode)
     # If any of the other joined tables are referenced in the group_by
     # however - the user is on their own
-    ( $prefetch_needs_subquery or $attrs->{_related_results_construction} )
+    ( $prefetch_needs_subquery or ! $attrs->{_simple_passthrough_construction} )
       and
     $attrs->{group_by}
       and
@@ -2875,6 +2872,7 @@ sub create_ddl_dir {
     add_drop_table => 1,
     ignore_constraint_names => 1,
     ignore_index_names => 1,
+    quote_identifiers => $self->sql_maker->_quoting_enabled,
     %{$sqltargs || {}}
   };
 
@@ -2969,10 +2967,21 @@ sub create_ddl_dir {
         unless $dest_schema->name;
     }
 
-    my $diff = SQL::Translator::Diff::schema_diff($source_schema, $db,
-                                                  $dest_schema,   $db,
-                                                  $sqltargs
-                                                 );
+    my $diff = do {
+      # FIXME - this is a terrible workaround for
+      # https://github.com/dbsrgits/sql-translator/commit/2d23c1e
+      # Fixing it in this sloppy manner so that we don't hve to
+      # lockstep an SQLT release as well. Needs to be removed at
+      # some point, and SQLT dep bumped
+      local $SQL::Translator::Producer::SQLite::NO_QUOTES
+        if $SQL::Translator::Producer::SQLite::NO_QUOTES;
+
+      SQL::Translator::Diff::schema_diff($source_schema, $db,
+                                         $dest_schema,   $db,
+                                         $sqltargs
+                                       );
+    };
+
     if(!open $file, ">$difffile") {
       $self->throw_exception("Can't write to $difffile ($!)");
       next;
@@ -3032,6 +3041,9 @@ sub deployment_statements {
   $sqltargs->{parser_args}{sources} = delete $sqltargs->{sources}
       if exists $sqltargs->{sources};
 
+  $sqltargs->{quote_identifiers} = $self->sql_maker->_quoting_enabled
+    unless exists $sqltargs->{quote_identifiers};
+
   my $tr = SQL::Translator->new(
     producer => "SQL::Translator::Producer::${type}",
     %$sqltargs,