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