lib/DBIx/Class/DeploymentHandler/DeployMethod/SQL/Translator/ScriptHelpers.pm

   1 package DBIx::Class::DeploymentHandler::DeployMethod::SQL::Translator::ScriptHelpers;
   2
   3 use strict;
   4 use warnings;
   5
   6 use Sub::Exporter::Progressive -setup => {
   7   exports => [qw(dbh schema_from_schema_loader)],
   8 };
   9
  10 use List::Util 'first';
  11
  12 sub dbh {
  13    my ($code) = @_;
  14    sub {
  15       my ($schema, $versions) = @_;
  16       $schema->storage->dbh_do(sub {
  17          $code->($_[1], $versions)
  18       })
  19    }
  20 }
  21
  22 sub _rearrange_connect_info {
  23    my ($storage) = @_;
  24
  25    my $nci = $storage->_normalize_connect_info($storage->connect_info);
  26
  27    return {
  28       dbh_maker => sub { $storage->dbh },
  29       map %{$nci->{$_}}, grep { $_ ne 'arguments' } keys %$nci,
  30    };
  31 }
  32
  33 my $count = 0;
  34 sub schema_from_schema_loader {
  35    my ($opts, $code) = @_;
  36
  37    die 'schema_from_schema_loader requires options!'
  38       unless $opts && ref $opts && ref $opts eq 'HASH';
  39
  40    die 'schema_from_schema_loader requires naming settings to be set!'
  41       unless $opts->{naming};
  42
  43    warn 'using "current" naming in a deployment script is begging for problems.  Just Say No.'
  44       if $opts->{naming} eq 'current' ||
  45         (ref $opts->{naming} eq 'HASH' && first { $_ eq 'current' } values %{$opts->{naming}});
  46    sub {
  47       my ($schema, $versions) = @_;
  48
  49       require DBIx::Class::Schema::Loader;
  50
  51       $schema->storage->ensure_connected;
  52       my @ci = _rearrange_connect_info($schema->storage);
  53
  54       my $new_schema = DBIx::Class::Schema::Loader::make_schema_at(
  55         'SHSchema::' . $count++, $opts, \@ci
  56       );
  57       my $sl_schema = $new_schema->connect(@ci);
  58       $code->($sl_schema, $versions)
  59    }
  60 }
  61
  62 1;
  63
  64 __END__
  65
  66 =head1 SYNOPSIS
  67
  68  use DBIx::Class::DeploymentHandler::DeployMethod::SQL::Translator::ScriptHelpers
  69    'schema_from_schema_loader';
  70
  71    schema_from_schema_loader({ naming => 'v4' }, sub {
  72       my ($schema, $version_set) = @_;
  73
  74       ...
  75    });
  76
  77 =head1 DESCRIPTION
  78
  79 This package is a set of coderef transforms for common use-cases in migrations.
  80 The subroutines are simply helpers for creating coderefs that will work for
  81 L<DBIx::Class::DeploymentHandler::DeployMethod::SQL::Translator/PERL SCRIPTS>,
  82 yet have some argument other than the current schema that you as a user might
  83 prefer.
  84
  85 =head1 EXPORTED SUBROUTINES
  86
  87 =head2 dbh($coderef)
  88
  89  dbh(sub {
  90    my ($dbh, $version_set) = @_;
  91
  92    ...
  93  });
  94
  95 For those times when you almost exclusively need access to "the bare metal".
  96 Simply gives you the correct database handle and the expected version set.
  97
  98 =head2 schema_from_schema_loader($sl_opts, $coderef)
  99
 100  schema_from_schema_loader({ naming => 'v4' }, sub {
 101    my ($schema, $version_set) = @_;
 102
 103    ...
 104  });
 105
 106 Any time you write a perl migration script that uses a L<DBIx::Class::Schema>
 107 you should probably use this.  Otherwise you'll run into problems if you remove
 108 a column from your schema yet still populate to it in an older population
 109 script.
 110
 111 Note that C<$sl_opts> requires that you specify something for the C<naming>
 112 option.