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

   1 package DBIx::Class::DeploymentHandler::DeployMethod::SQL::Translator::ScriptHelpers;
   2
   3 # ABSTRACT: CodeRef Transforms for common use-cases in DBICDH Migrations
   4
   5 use strict;
   6 use warnings;
   7
   8 use Sub::Exporter::Progressive -setup => {
   9   exports => [qw(dbh schema_from_schema_loader)],
  10 };
  11
  12 use List::Util 'first';
  13 use Text::Brew 'distance';
  14 use Try::Tiny;
  15 use DBIx::Class::DeploymentHandler::LogImporter qw(:dlog);
  16
  17 sub dbh {
  18    my ($code) = @_;
  19    sub {
  20       my ($schema, $versions) = @_;
  21       $schema->storage->dbh_do(sub {
  22          $code->($_[1], $versions)
  23       })
  24    }
  25 }
  26
  27 sub _rearrange_connect_info {
  28    my ($storage) = @_;
  29
  30    my $nci = $storage->_normalize_connect_info($storage->connect_info);
  31
  32    return {
  33       dbh_maker => sub { $storage->dbh },
  34       map %{$nci->{$_}}, grep { $_ ne 'arguments' } keys %$nci,
  35    };
  36 }
  37
  38 my $count = 0;
  39 sub schema_from_schema_loader {
  40    my ($opts, $code) = @_;
  41
  42    die 'schema_from_schema_loader requires options!'
  43       unless $opts && ref $opts && ref $opts eq 'HASH';
  44
  45    die 'schema_from_schema_loader requires naming settings to be set!'
  46       unless $opts->{naming};
  47
  48    warn 'using "current" naming in a deployment script is begging for problems.  Just Say No.'
  49       if $opts->{naming} eq 'current' ||
  50         (ref $opts->{naming} eq 'HASH' && first { $_ eq 'current' } values %{$opts->{naming}});
  51
  52    $opts->{debug} = 1
  53       if !exists $opts->{debug} && $ENV{DBICDH_TRACE};
  54
  55    sub {
  56       my ($schema, $versions) = @_;
  57
  58       require DBIx::Class::Schema::Loader;
  59
  60       $schema->storage->ensure_connected;
  61       my @ci = _rearrange_connect_info($schema->storage);
  62
  63       my $new_schema = DBIx::Class::Schema::Loader::make_schema_at(
  64         'SHSchema::' . $count++, $opts, \@ci
  65       );
  66
  67       Dlog_debug {
  68          "schema_from_schema_loader generated the following sources: $_"
  69       } [ $new_schema->sources ];
  70       my $sl_schema = $new_schema->connect(@ci);
  71       try {
  72          $code->($sl_schema, $versions)
  73       } catch {
  74          if (m/Can't find source for (.+?) at/) {
  75             my @presentsources = map {
  76               (distance($_, $1))[0] < 3 ? "$_ <== Possible Match\n" : "$_\n";
  77             } $sl_schema->sources;
  78
  79             die <<"ERR";
  80 $_
  81 You are seeing this error because the DBIx::Class::ResultSource in your
  82 migration script called "$1" is not part of the schema that ::Schema::Loader
  83 has inferred from your existing database.
  84
  85 To help you debug this issue, here's a list of the actual sources that the
  86 schema available to your migration knows about:
  87
  88  @presentsources
  89 ERR
  90          }
  91          die $_;
  92       }
  93    }
  94 }
  95
  96 1;
  97
  98 __END__
  99
 100 =head1 SYNOPSIS
 101
 102  use DBIx::Class::DeploymentHandler::DeployMethod::SQL::Translator::ScriptHelpers
 103    'schema_from_schema_loader';
 104
 105    schema_from_schema_loader({ naming => 'v4' }, sub {
 106       my ($schema, $version_set) = @_;
 107
 108       ...
 109    });
 110
 111 =head1 DESCRIPTION
 112
 113 This package is a set of coderef transforms for common use-cases in migrations.
 114 The subroutines are simply helpers for creating coderefs that will work for
 115 L<DBIx::Class::DeploymentHandler::DeployMethod::SQL::Translator/PERL SCRIPTS>,
 116 yet have some argument other than the current schema that you as a user might
 117 prefer.
 118
 119 =head1 EXPORTED SUBROUTINES
 120
 121 =head2 dbh($coderef)
 122
 123  dbh(sub {
 124    my ($dbh, $version_set) = @_;
 125
 126    ...
 127  });
 128
 129 For those times when you almost exclusively need access to "the bare metal".
 130 Simply gives you the correct database handle and the expected version set.
 131
 132 =head2 schema_from_schema_loader($sl_opts, $coderef)
 133
 134  schema_from_schema_loader({ naming => 'v4' }, sub {
 135    my ($schema, $version_set) = @_;
 136
 137    ...
 138  });
 139
 140 Any time you write a perl migration script that uses a L<DBIx::Class::Schema>
 141 you should probably use this.  Otherwise you'll run into problems if you remove
 142 a column from your schema yet still populate to it in an older population
 143 script.
 144
 145 Note that C<$sl_opts> requires that you specify something for the C<naming>
 146 option.