initial version of ::ScriptHelpers

diff --git a/dist.ini b/dist.ini
index 4e72e69..b18bb78 100644 (file)
--- a/dist.ini
+++ b/dist.ini
@@ -39,3 +39,4 @@ DBD::SQLite                 = 1.35
 Carp                        = 0
 Carp::Clan                  = 0
 aliased                     = 0
+Test::Requires              = 0.06

diff --git a/lib/DBIx/Class/DeploymentHandler/DeployMethod/SQL/Translator/ScriptHelpers.pm b/lib/DBIx/Class/DeploymentHandler/DeployMethod/SQL/Translator/ScriptHelpers.pm
new file mode 100644 (file)
index 0000000..2bdf7f4
--- /dev/null
+++ b/lib/DBIx/Class/DeploymentHandler/DeployMethod/SQL/Translator/ScriptHelpers.pm
@@ -0,0 +1,112 @@
+package DBIx::Class::DeploymentHandler::DeployMethod::SQL::Translator::ScriptHelpers;
+
+use strict;
+use warnings;
+
+use Sub::Exporter -setup => {
+  exports => [qw(dbh schema_from_schema_loader)],
+};
+
+use List::Util 'first';
+
+sub dbh {
+   my ($code) = @_;
+   sub {
+      my ($schema, $versions) = @_;
+      $schema->storage->dbh_do(sub {
+         $code->($_[1], $versions)
+      })
+   }
+}
+
+sub _rearrange_connect_info {
+   my ($storage) = @_;
+
+   my $nci = $storage->_normalize_connect_info($storage->connect_info);
+
+   return {
+      dbh_maker => sub { $storage->dbh },
+      map %{$nci->{$_}}, grep { $_ ne 'arguments' } keys %$nci,
+   };
+}
+
+my $count = 0;
+sub schema_from_schema_loader {
+   my ($opts, $code) = @_;
+
+   die 'schema_from_schema_loader requires options!'
+      unless $opts && ref $opts && ref $opts eq 'HASH';
+
+   die 'schema_from_schema_loader requires naming settings to be set!'
+      unless $opts->{naming};
+
+   warn 'using "current" naming in a deployment script is begging for problems.  Just Say No.'
+      if $opts->{naming} eq 'current' ||
+        (ref $opts->{naming} eq 'HASH' && first { $_ eq 'current' } values %{$opts->{naming}});
+   sub {
+      my ($schema, $versions) = @_;
+
+      require DBIx::Class::Schema::Loader;
+
+      $schema->storage->ensure_connected;
+      my @ci = _rearrange_connect_info($schema->storage);
+
+      my $new_schema = DBIx::Class::Schema::Loader::make_schema_at(
+        'SHSchema::' . $count++, $opts, \@ci
+      );
+      my $sl_schema = $new_schema->connect(@ci);
+      $code->($sl_schema, $versions)
+   }
+}
+
+1;
+
+__END__
+
+=head1 SYNOPSIS
+
+ use DBIx::Class::DeploymentHandler::DeployMethod::SQL::Translator::ScriptHelpers
+   'schema_from_schema_loader';
+
+   schema_from_schema_loader({ naming => 'v4' }, sub {
+      my ($schema, $version_set) = @_;
+
+      ...
+   });
+
+=head1 DESCRIPTION
+
+This package is a set of coderef transforms for common use-cases in migrations.
+The subroutines are simply helpers for creating coderefs that will work for
+L<DBIx::Class::DeploymentHandler::DeployMethod::SQL::Translator/PERL SCRIPTS>,
+yet have some argument other than the current schema that you as a user might
+prefer.
+
+=head1 EXPORTED SUBROUTINES
+
+=head2 dbh($coderef)
+
+ dbh(sub {
+   my ($dbh, $version_set) = @_;
+
+   ...
+ });
+
+For those times when you almost exclusively need access to "the bare metal".
+Simply gives you the correct database handle and the expected version set.
+
+=head2 schema_from_schema_loader($sl_opts, $coderef)
+
+ schema_from_schema_loader({ naming => 'v4' }, sub {
+   my ($schema, $version_set) = @_;
+
+   ...
+ });
+
+Any time you write a perl migration script that uses a L<DBIx::Class::Schema>
+you should probably use this.  Otherwise you'll run into problems if you remove
+a column from your schema yet still populate to it in an older population
+script.
+
+Note that C<$sl_opts> requires that you specify something for the C<naming>
+option.

diff --git a/t/deploy_methods/script-helpers.t b/t/deploy_methods/script-helpers.t
new file mode 100644 (file)
index 0000000..c621f53
--- /dev/null
+++ b/t/deploy_methods/script-helpers.t
@@ -0,0 +1,89 @@
+#!perl
+
+use strict;
+use warnings;
+
+use Test::More;
+use DBIx::Class::DeploymentHandler::DeployMethod::SQL::Translator::ScriptHelpers ':all';;
+
+use lib 't/lib';
+
+use DBICVersion_v1;
+use DBICDHTest;
+
+my $dbh = DBICDHTest->dbh;
+my @connection = (sub { $dbh }, { ignore_version => 1 });
+my $schema = DBICVersion::Schema->connect(@connection);
+$schema->deploy;
+
+subtest dbh => sub {
+   my $ran;
+   dbh(sub {
+      my ($dbh, $versions) = @_;
+
+      $ran = 1;
+
+      is($dbh, $schema->storage->dbh, 'dbh is correctly reused');
+      is_deeply $versions, [1,2], 'version correctly passed';
+      isa_ok($dbh, 'DBI::db');
+   })->($schema, [1,2]);
+
+   ok $ran, 'coderef ran';
+};
+
+subtest schema_from_schema_loader => sub {
+   use Test::Requires;
+   test_requires('DBIx::Class::Schema::Loader');
+   my $build_sl_test = sub {
+      my @connection = @_;
+
+      return sub {
+         my $ran;
+         my $outer_schema = DBICVersion::Schema->connect(@connection);
+         $outer_schema->deploy;
+         schema_from_schema_loader({ naming => 'v4' }, sub {
+            my ($schema, $versions) = @_;
+
+            $ran = 1;
+
+            is(
+               $outer_schema->storage->dbh,
+               $schema->storage->dbh,
+               'dbh is correctly reused',
+            );
+            is_deeply $versions, [2,3], 'version correctly passed';
+            like(ref $schema, qr/SHSchema::\d+/, 'schema has expected type');
+            isa_ok($schema, 'DBIx::Class::Schema', 'and schema is not totally worthless -');
+         })->($outer_schema, [2,3]);
+
+         ok $ran, 'coderef ran';
+      }
+   };
+
+   subtest 'sub { $dbh }, ...' => $build_sl_test->(
+      sub { DBICDHTest->dbh },
+      { ignore_version => 1 },
+   );
+   subtest '$dsn, $user, $pass, ...' => $build_sl_test->(
+      'dbi:SQLite::memory:', undef, undef,
+      { RaiseError => 1 },
+      { ignore_version => 1 }
+   );
+
+   subtest '({ dsn => ..., ... })' => $build_sl_test->({
+      dsn => 'dbi:SQLite::memory:',
+      user => undef,
+      password => undef,
+      RaiseError => 1,
+      ignore_version => 1,
+   });
+
+   subtest '({ dbh_maker => ..., ... })' => $build_sl_test->({
+      dbh_maker => sub { DBICDHTest->dbh },
+      RaiseError => 1,
+      ignore_version => 1,
+   });
+};
+
+done_testing;
+