more details in the AuthorCheck.pm to help newcomers understand why they are being...

diff --git a/lib/DBIx/Class/Storage/DBI.pm b/lib/DBIx/Class/Storage/DBI.pm
index 7be8aab..a8be5d0 100644 (file)
--- a/lib/DBIx/Class/Storage/DBI.pm
+++ b/lib/DBIx/Class/Storage/DBI.pm
@@ -9,6 +9,7 @@ use Carp::Clan qw/^DBIx::Class/;
 use DBI;
 use DBIx::Class::Storage::DBI::Cursor;
 use DBIx::Class::Storage::Statistics;
+use Path::Class::File ();
 use Scalar::Util qw/blessed weaken/;
 use List::Util();
 
@@ -1826,6 +1827,147 @@ sub lag_behind_master {
     return;
 }
 
+=head2 run_file_against_storage (Path::Class::File|String|@Strings)
+
+Given a path to file, will try to execute it line by line against the connected
+database engine.  Throws an exception and tries to rollback if an error occurs.
+
+Will normalize the contents of the file to strip comments and properly deal
+with command scattered across several lines.
+
+Will accept either a L<Path::Class::File> object or a string or array that we
+can use to create one.
+
+Returns an array of whatever comes back from executing each statement.  Should
+be true if the script executes anything at all.
+
+=cut
+
+sub run_file_against_storage {
+       my ($self, @args) = @_;
+       my $fh = $self->_normalize_fh_from_args(@args);
+       my @lines = $self->_normalize_lines_from_fh($fh);
+       my @statements = $self->_normalize_statements_from_lines(join(' ', @lines));
+       return $self->txn_do(sub {
+               my @return;
+               foreach my $statement (@statements) {
+                       push @return, $self->_execute_single_statement(@$statement);
+               }
+               return @return;
+       });
+}
+
+=head2 _execute_single_statement ($String|@Strings)
+
+Given a SQL statement, do our best to safely execute it.
+
+=cut
+
+sub _execute_single_statement {
+       my ($self, $statement) = @_;
+       if($statement) {
+               return $self->dbh_do(sub {
+                       my ($storage, $dbh, $schema, $statement) = @_;
+                       $storage->debugobj->query_start("Doing: $statement")
+                        if $storage->debug;
+                       $dbh->do($statement) 
+                        || $schema->throw_exception("Can't execute line: $statement, Error: ". $dbh->errstr);
+                       $storage->debugobj->query_end("Done: $statement")
+                        if $storage->debug;
+               }, $self, $statement);
+       } else {
+               $self->debugobj("No commands to do!")
+                if $self->debug;
+               return;
+       }
+}
+
+=head2 _normalize_fh_from_args (Path::Class::File|String|@Strings)
+
+Given some args, return a $filehandle that is an open read filehandle object
+based on the args.  Accepts a L<Path::Class::File> object or arguments suitable
+for constructing one.
+
+Returns a filehandle whose end of line characters have been normalized to the
+running platform.
+
+=cut
+
+sub _normalize_fh_from_args {
+       my ($self, @args) = @_;
+       my $file = Path::Class::File->new(@args);
+       open(my $fh, "<:raw:eol(NATIVE)", $file) ||
+         $self->throw_exception("Can't open file '$file'. Error: $!");
+       return $fh;
+}
+
+=head2 _normalize_lines_from_fh ($filehandle)
+
+Given a $filehandle, will return an array of normalized lines statement that we
+can group into statements.  We do our best to strip out comment lines, blank
+lines and anything else that might cause an error.  We also split lines based
+on the ';' deliminator, since that's pretty standard.
+
+=cut
+
+sub _normalize_lines_from_fh {
+       my ($self, $fh) = @_;
+
+       my $deliminator=qr{;|.$};
+       my $quote=qr{'|"};
+       my $quoted=qr{$quote.+?$quote};
+       my $block=qr{$quoted|.};
+       my $comment = qr{--};
+
+       my @lines;
+       foreach my $line (<$fh>) {
+               chomp $line;
+               ## Skip if the line is blank, whitespace only or a comment line 
+               if(!$line || $line=~m/^\s* $comment/x || $line=~m/^\s*$/) {
+                       next;
+               } else {
+                       ## a line may contain several commands
+                       my @parts = ($line=~m/$block*?$deliminator/xg);
+                       ## clean empty or comment only lines
+                       @parts = grep { $_ && $_ !~m/^\s* $comment/x } @parts;
+                       ## We are going to wrap it all in a transaction anyway
+                       @parts = grep { $_ !~ /^(BEGIN|BEGIN TRANSACTION|COMMIT)/m } @parts;
+                       ## Some cleanup
+                       @parts = map {
+                               $_=~s/$deliminator \s*?$comment.*?$//x; ## trim off ending comments                             
+                               $_=~s/^\s*//g; ## trim leading whitespace
+                               $_=~s/\s*$//g; ## trim ending whitespace
+                               $_
+                       } @parts;
+                       push @lines, @parts;
+               }
+       }
+       return @lines;
+}
+
+=head2 _normalize_statements_from_lines (@lines)
+
+Give an array of lines, group them into whole statements.  This is to handle
+how a given statement might have been broken across multiple lines
+
+Returns an array of arrayrefs.
+
+=cut
+
+sub _normalize_statements_from_lines {
+       my ($self, @lines) = @_;
+       my @statements;
+       my $statement = [];
+       foreach my $line (@lines) {
+               push @{$statement}, $line;
+               if($line=~m/;$/) {
+                       push @statements, $statement;
+                       $statement = [];
+               }
+       }
+       return @statements;     
+}
+
 sub DESTROY {
   my $self = shift;
   return if !$self->_dbh;

diff --git a/t/lib/DBICTest/AuthorCheck.pm b/t/lib/DBICTest/AuthorCheck.pm
index 4d2a6f6..475c1ec 100644 (file)
--- a/t/lib/DBICTest/AuthorCheck.pm
+++ b/t/lib/DBICTest/AuthorCheck.pm
@@ -34,14 +34,22 @@ sub _check_author_makefile {
   );
 
   return unless $mf_pl_mtime;   # something went wrong during co_root detection ?
+  
+  my @reasons;
+  
+  if(not -d $root->subdir ('inc')) {
+       push @reasons, "Missing inc directory";
+  }
+  
+  if(not $mf_mtime) {
+       push @reasons, "Missing Makefile";
+  }
 
-  if (
-    not -d $root->subdir ('inc') 
-      or
-    not $mf_mtime
-      or
-    $mf_mtime < $mf_pl_mtime
-  ) {
+  if($mf_mtime < $mf_pl_mtime) {
+       push @reasons, "Makefile.PL is newer than Makefile";
+  }
+  
+  if (@reasons) {
     print STDERR <<'EOE';
 
 
@@ -71,10 +79,14 @@ entirely.
 
 The DBIC team
 
-
-
 EOE
 
+       print STDERR "Reasons you received this message:\n\n";
+       foreach my $reason (@reasons) {
+               print STDERR "\t* $reason\n";
+       }
+       print STDERR "\n\n";
+
     exit 1;
   }
 }