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; |
855a668c |
13 | use DBIx::Class::DeploymentHandler::LogImporter qw(:dlog); |
3467d1a5 |
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}}); |
ae521c55 |
49 | |
855a668c |
50 | $opts->{debug} = 1 |
51 | if !exists $opts->{debug} && $ENV{DBICDH_TRACE}; |
52 | |
3467d1a5 |
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 | ); |
855a668c |
64 | |
65 | Dlog_debug { |
66 | "schema_from_schema_loader generated the following sources: $_" |
67 | } [ $new_schema->sources ]; |
3467d1a5 |
68 | my $sl_schema = $new_schema->connect(@ci); |
ae521c55 |
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 | } |
3467d1a5 |
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. |