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