From: Arthur Axel 'fREW' Schmidt <frioux@gmail.com>
Date: Sat, 3 Mar 2012 22:55:26 +0000 (-0600)
Subject: Wrap upgrades, downgrades, and installs in a transaction
X-Git-Tag: v0.002100~1
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?p=dbsrgits%2FDBIx-Class-DeploymentHandler.git;a=commitdiff_plain;h=1fcd4fe6717e0809422856c89673fc78b43174bb

Wrap upgrades, downgrades, and installs in a transaction
---

diff --git a/Changes b/Changes
index 1d1920a..a70eec9 100644
--- a/Changes
+++ b/Changes
@@ -1,6 +1,8 @@
 Revision history for {{$dist->name}}
 
 {{$NEXT}}
+       - Wrap upgrades, downgrades, and installs in a transaction, as a failure
+         to add a version to the version table should cause a rollback
        - Allow user to specify version of schema to install
        - Added better sandboxing (stolen straight from Plack::Util) for coderefs
          to avoid accidental leakage
diff --git a/dist.ini b/dist.ini
index 8807868..7279bb4 100644
--- a/dist.ini
+++ b/dist.ini
@@ -40,3 +40,4 @@ Carp                        = 0
 Carp::Clan                  = 0
 aliased                     = 0
 Test::Requires              = 0.06
+Context::Preserve           = 0.01
diff --git a/lib/DBIx/Class/DeploymentHandler/Dad.pm b/lib/DBIx/Class/DeploymentHandler/Dad.pm
index 569a9f7..7b6247b 100644
--- a/lib/DBIx/Class/DeploymentHandler/Dad.pm
+++ b/lib/DBIx/Class/DeploymentHandler/Dad.pm
@@ -48,11 +48,13 @@ sub install {
   croak 'Install not possible as versions table already exists in database'
     if $self->version_storage_is_installed;
 
-  my $ddl = $self->deploy({ version=> $version });
+  $self->txn_do(sub {
+     my $ddl = $self->deploy({ version=> $version });
 
-  $self->add_database_version({
-    version     => $self->to_version,
-    ddl         => $ddl,
+     $self->add_database_version({
+       version     => $self->to_version,
+       ddl         => $ddl,
+     });
   });
 }
 
@@ -60,18 +62,20 @@ sub upgrade {
   log_info { 'upgrading' };
   my $self = shift;
   my $ran_once = 0;
-  while ( my $version_list = $self->next_version_set ) {
-    $ran_once = 1;
-    my ($ddl, $upgrade_sql) = @{
-      $self->upgrade_single_step({ version_set => $version_list })
-    ||[]};
-
-    $self->add_database_version({
-      version     => $version_list->[-1],
-      ddl         => $ddl,
-      upgrade_sql => $upgrade_sql,
-    });
-  }
+  $self->txn_do(sub {
+     while ( my $version_list = $self->next_version_set ) {
+       $ran_once = 1;
+       my ($ddl, $upgrade_sql) = @{
+         $self->upgrade_single_step({ version_set => $version_list })
+       ||[]};
+
+       $self->add_database_version({
+         version     => $version_list->[-1],
+         ddl         => $ddl,
+         upgrade_sql => $upgrade_sql,
+       });
+     }
+  });
 
   log_warn { 'no need to run upgrade' } unless $ran_once;
 }
@@ -80,13 +84,15 @@ sub downgrade {
   log_info { 'downgrading' };
   my $self = shift;
   my $ran_once = 0;
-  while ( my $version_list = $self->previous_version_set ) {
-    $ran_once = 1;
-    $self->downgrade_single_step({ version_set => $version_list });
-
-    # do we just delete a row here?  I think so but not sure
-    $self->delete_database_version({ version => $version_list->[0] });
-  }
+  $self->txn_do(sub {
+     while ( my $version_list = $self->previous_version_set ) {
+       $ran_once = 1;
+       $self->downgrade_single_step({ version_set => $version_list });
+
+       # do we just delete a row here?  I think so but not sure
+       $self->delete_database_version({ version => $version_list->[0] });
+     }
+  });
   log_warn { 'no version to run downgrade' } unless $ran_once;
 }
 
@@ -199,6 +205,10 @@ See L<DBIx::Class::DeploymentHandler::HandlesDeploy/upgrade_single_step>.
 
 See L<DBIx::Class::DeploymentHandler::HandlesDeploy/downgrade_single_step>.
 
+=head2 txn_do
+
+See L<DBIx::Class::DeploymentHandler::HandlesDeploy/txn_do>.
+
 =head1 ORTHODOX METHODS
 
 These methods are not actually B<required> as things will probably still work
diff --git a/lib/DBIx/Class/DeploymentHandler/DeployMethod/SQL/Translator.pm b/lib/DBIx/Class/DeploymentHandler/DeployMethod/SQL/Translator.pm
index d1385ee..16f97cd 100644
--- a/lib/DBIx/Class/DeploymentHandler/DeployMethod/SQL/Translator.pm
+++ b/lib/DBIx/Class/DeploymentHandler/DeployMethod/SQL/Translator.pm
@@ -10,6 +10,7 @@ use Log::Contextual qw(:log :dlog), -package_logger =>
   DBIx::Class::DeploymentHandler::Logger->new({
     env_prefix => 'DBICDH'
   });
+use Context::Preserve;
 
 use Try::Tiny;
 
@@ -325,30 +326,37 @@ sub _run_perl {
   }
 }
 
-sub _run_sql_and_perl {
-  my ($self, $filenames, $sql_to_run, $versions) = @_;
-  my @files   = @{$filenames};
-  my $guard   = $self->schema->txn_scope_guard if $self->txn_wrap;
+sub txn_do {
+   my ( $self, $code ) = @_;
+   return $code->() unless $self->txn_wrap;
 
-  $self->_run_sql_array($sql_to_run) if $self->ignore_ddl;
+   my $guard = $self->schema->txn_scope_guard;
 
-  my $sql = ($sql_to_run)?join ";\n", @$sql_to_run:'';
-  FILENAME:
-  for my $filename (@files) {
-    if ($self->ignore_ddl && $filename =~ /^[^_]*-auto.*\.sql$/) {
-      next FILENAME
-    } elsif ($filename =~ /\.sql$/) {
-       $sql .= $self->_run_sql($filename)
-    } elsif ( $filename =~ /\.pl$/ ) {
-       $self->_run_perl($filename, $versions)
-    } else {
-      croak "A file ($filename) got to deploy that wasn't sql or perl!";
-    }
-  }
+   return preserve_context { $code->() } after => sub { $guard->commit };
+}
 
-  $guard->commit if $self->txn_wrap;
+sub _run_sql_and_perl {
+  my ($self, $filenames, $sql_to_run, $versions) = @_;
+  my @files   = @{$filenames};
+  $self->txn_do(sub {
+     $self->_run_sql_array($sql_to_run) if $self->ignore_ddl;
+
+     my $sql = ($sql_to_run)?join ";\n", @$sql_to_run:'';
+     FILENAME:
+     for my $filename (@files) {
+       if ($self->ignore_ddl && $filename =~ /^[^_]*-auto.*\.sql$/) {
+         next FILENAME
+       } elsif ($filename =~ /\.sql$/) {
+          $sql .= $self->_run_sql($filename)
+       } elsif ( $filename =~ /\.pl$/ ) {
+          $self->_run_perl($filename, $versions)
+       } else {
+         croak "A file ($filename) got to deploy that wasn't sql or perl!";
+       }
+     }
 
-  return $sql;
+     return $sql;
+  });
 }
 
 sub deploy {
diff --git a/lib/DBIx/Class/DeploymentHandler/HandlesDeploy.pm b/lib/DBIx/Class/DeploymentHandler/HandlesDeploy.pm
index d5169a6..c931d42 100644
--- a/lib/DBIx/Class/DeploymentHandler/HandlesDeploy.pm
+++ b/lib/DBIx/Class/DeploymentHandler/HandlesDeploy.pm
@@ -17,6 +17,8 @@ requires 'upgrade_single_step';
 requires 'prepare_downgrade';
 requires 'downgrade_single_step';
 
+requires 'txn_do';
+
 1;
 
 # vim: ts=2 sw=2 expandtab
@@ -108,6 +110,12 @@ Optionally return C<< [ $ddl, $upgrade_sql ] >> where C<$ddl> is the DDL for
 that version of the schema and C<$upgrade_sql> is the SQL that was run to
 upgrade the database.
 
+=method txn_do
+
+ $dh->txn_do(sub { ... })
+
+Wrap the passed coderef in a transaction (if transactions are enabled.)
+
 =head1 KNOWN IMPLEMENTATIONS
 
 =over