Commit | Line | Data |
3467d1a5 |
1 | package DBIx::Class::DeploymentHandler::DeployMethod::SQL::Translator::ScriptHelpers; |
2 | |
3 | use strict; |
4 | use warnings; |
5 | |
10557c59 |
6 | use Sub::Exporter::Progressive -setup => { |
3467d1a5 |
7 | exports => [qw(dbh schema_from_schema_loader)], |
8 | }; |
9 | |
10 | use List::Util 'first'; |
ae521c55 |
11 | use Text::Brew 'distance'; |
12 | use Try::Tiny; |
3467d1a5 |
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}}); |
ae521c55 |
48 | |
3467d1a5 |
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); |
ae521c55 |
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 | } |
3467d1a5 |
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. |