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