Commit | Line | Data |
3467d1a5 |
1 | package DBIx::Class::DeploymentHandler::DeployMethod::SQL::Translator::ScriptHelpers; |
2 | |
624e2add |
3 | # ABSTRACT: CodeRef Transforms for common use-cases in DBICDH Migrations |
4 | |
3467d1a5 |
5 | use strict; |
6 | use warnings; |
7 | |
10557c59 |
8 | use Sub::Exporter::Progressive -setup => { |
3467d1a5 |
9 | exports => [qw(dbh schema_from_schema_loader)], |
10 | }; |
11 | |
12 | use List::Util 'first'; |
ae521c55 |
13 | use Text::Brew 'distance'; |
14 | use Try::Tiny; |
855a668c |
15 | use DBIx::Class::DeploymentHandler::LogImporter qw(:dlog); |
3467d1a5 |
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}}); |
ae521c55 |
51 | |
855a668c |
52 | $opts->{debug} = 1 |
53 | if !exists $opts->{debug} && $ENV{DBICDH_TRACE}; |
54 | |
3467d1a5 |
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 | ); |
855a668c |
66 | |
67 | Dlog_debug { |
68 | "schema_from_schema_loader generated the following sources: $_" |
69 | } [ $new_schema->sources ]; |
3467d1a5 |
70 | my $sl_schema = $new_schema->connect(@ci); |
ae521c55 |
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 | } |
3467d1a5 |
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. |