Lazy-load as many of the non-essential modules as possible

[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 7d7a8bb..1448bc3 100644 (file)
--- a/lib/DBIx/Class/Storage/DBI.pm
+++ b/lib/DBIx/Class/Storage/DBI.pm
@@ -12,10 +12,8 @@ use DBI;
 use DBIx::Class::Storage::DBI::Cursor;
 use Scalar::Util qw/refaddr weaken reftype blessed/;
 use List::Util qw/first/;
-use Data::Dumper::Concise 'Dumper';
 use Sub::Name 'subname';
 use Try::Tiny;
-use File::Path 'make_path';
 use overload ();
 use namespace::clean;
 
@@ -1161,7 +1159,13 @@ sub _server_info {
 }
 
 sub _get_server_version {
-  shift->_get_dbh->get_info(18);
+  shift->_dbh_get_info(18);
+}
+
+sub _dbh_get_info {
+  my ($self, $info) = @_;
+
+  return try { $self->_get_dbh->get_info($info) } || undef;
 }
 
 sub _determine_driver {
@@ -1205,6 +1209,8 @@ sub _determine_driver {
 
     $self->_driver_determined(1);
 
+    Class::C3->reinitialize() if DBIx::Class::_ENV_::OLD_MRO;
+
     $self->_init; # run driver-specific initializations
 
     $self->_run_connection_actions
@@ -1770,10 +1776,11 @@ sub insert_bulk {
       $msg,
       $cols->[$col_idx],
       do {
+        require Data::Dumper::Concise;
         local $Data::Dumper::Maxdepth = 1; # don't dump objects, if any
-        Dumper {
+        Data::Dumper::Concise::Dumper ({
           map { $cols->[$_] => $data->[$slice_idx][$_] } (0 .. $#$cols)
-        },
+        }),
       }
     );
   };
@@ -1914,9 +1921,10 @@ sub _execute_array {
     $self->throw_exception("Unexpected populate error: $err")
       if ($i > $#$tuple_status);
 
+    require Data::Dumper::Concise;
     $self->throw_exception(sprintf "%s for populate slice:\n%s",
       ($tuple_status->[$i][1] || $err),
-      Dumper { map { $cols->[$_] => $data->[$i][$_] } (0 .. $#$cols) },
+      Data::Dumper::Concise::Dumper( { map { $cols->[$_] => $data->[$i][$_] } (0 .. $#$cols) } ),
     );
   }
 
@@ -2280,7 +2288,18 @@ sub _dbh_sth {
 
   # XXX You would think RaiseError would make this impossible,
   #  but apparently that's not true :(
-  $self->throw_exception($dbh->errstr) if !$sth;
+  $self->throw_exception(
+    $dbh->errstr
+      ||
+    sprintf( "\$dbh->prepare() of '%s' through %s failed *silently* without "
+            .'an exception and/or setting $dbh->errstr',
+      length ($sql) > 20
+        ? substr($sql, 0, 20) . '...'
+        : $sql
+      ,
+      'DBD::' . $dbh->{Driver}{Name},
+    )
+  ) if !$sth;
 
   $sth;
 }
@@ -2555,10 +2574,10 @@ sub create_ddl_dir {
   } else {
       -d $dir
         or
-      make_path ("$dir")  # make_path does not like objects (i.e. Path::Class::Dir)
+      (require File::Path and File::Path::make_path ("$dir"))  # make_path does not like objects (i.e. Path::Class::Dir)
         or
       $self->throw_exception(
-        "Failed to create '$dir': " . ($! || $@ || 'error unknow')
+        "Failed to create '$dir': " . ($! || $@ || 'error unknown')
       );
   }
 
@@ -2713,6 +2732,7 @@ sub deployment_statements {
   my $filename = $schema->ddl_filename($type, $version, $dir);
   if(-f $filename)
   {
+      # FIXME replace this block when a proper sane sql parser is available
       my $file;
       open($file, "<$filename")
         or $self->throw_exception("Can't open $filename ($!)");
@@ -2751,12 +2771,14 @@ sub deployment_statements {
   return wantarray ? @ret : $ret[0];
 }
 
+# FIXME deploy() currently does not accurately report sql errors
+# Will always return true while errors are warned
 sub deploy {
   my ($self, $schema, $type, $sqltargs, $dir) = @_;
   my $deploy = sub {
     my $line = shift;
-    return if($line =~ /^--/);
     return if(!$line);
+    return if($line =~ /^--/);
     # next if($line =~ /^DROP/m);
     return if($line =~ /^BEGIN TRANSACTION/m);
     return if($line =~ /^COMMIT/m);
@@ -2778,7 +2800,8 @@ sub deploy {
     }
   }
   elsif (@statements == 1) {
-    foreach my $line ( split(";\n", $statements[0])) {
+    # split on single line comments and end of statements
+    foreach my $line ( split(/\s*--.*\n|;\n/, $statements[0])) {
       $deploy->( $line );
     }
   }
@@ -2914,12 +2937,27 @@ sub _max_column_bytesize {
 }
 
 # Determine if a data_type is some type of BLOB
+# FIXME: these regexes are expensive, result of these checks should be cached in
+# the column_info .
 sub _is_lob_type {
   my ($self, $data_type) = @_;
-  $data_type && ($data_type =~ /(?:lob|bfile|text|image|bytea|memo)/i
-    || $data_type =~ /^long(?:\s*(?:raw|bit\s*varying|varbit|binary
+  $data_type && ($data_type =~ /lob|bfile|text|image|bytea|memo/i
+    || $data_type =~ /^long(?:\s+(?:raw|bit\s*varying|varbit|binary
                                   |varchar|character\s*varying|nvarchar
-                                  |national\s*character\s*varying))?$/xi);
+                                  |national\s*character\s*varying))?\z/xi);
+}
+
+sub _is_binary_lob_type {
+  my ($self, $data_type) = @_;
+  $data_type && ($data_type =~ /blob|bfile|image|bytea/i
+    || $data_type =~ /^long(?:\s+(?:raw|bit\s*varying|varbit|binary))?\z/xi);
+}
+
+sub _is_text_lob_type {
+  my ($self, $data_type) = @_;
+  $data_type && ($data_type =~ /^(?:clob|memo)\z/i
+    || $data_type =~ /^long(?:\s+(?:varchar|character\s*varying|nvarchar
+                        |national\s*character\s*varying))\z/xi);
 }
 
 1;