From: Arthur Axel 'fREW' Schmidt Date: Wed, 22 Feb 2012 03:37:19 +0000 (-0600) Subject: initial version of ::ScriptHelpers X-Git-Tag: v0.002000~2 X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=3467d1a5f6490810b79a74da040dd28396a9d7c4;p=dbsrgits%2FDBIx-Class-DeploymentHandler.git initial version of ::ScriptHelpers --- diff --git a/dist.ini b/dist.ini index 4e72e69..b18bb78 100644 --- 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 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, +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 +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 +option. diff --git a/t/deploy_methods/script-helpers.t b/t/deploy_methods/script-helpers.t new file mode 100644 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; +