line |
stmt |
bran |
cond |
sub |
pod |
time |
code |
1
|
|
|
|
|
|
|
package DBIx::Class::DeploymentHandler::DeployMethod::SQL::Translator; |
2
|
|
|
|
|
|
|
$DBIx::Class::DeploymentHandler::DeployMethod::SQL::Translator::VERSION = '0.002232'; |
3
|
18
|
|
|
18
|
|
1017193
|
use Moose; |
|
18
|
|
|
|
|
2638389
|
|
|
18
|
|
|
|
|
142
|
|
4
|
|
|
|
|
|
|
|
5
|
|
|
|
|
|
|
# ABSTRACT: Manage your SQL and Perl migrations in nicely laid out directories |
6
|
|
|
|
|
|
|
|
7
|
18
|
|
|
18
|
|
138055
|
use autodie; |
|
18
|
|
|
|
|
248249
|
|
|
18
|
|
|
|
|
181
|
|
8
|
18
|
|
|
18
|
|
122270
|
use Carp qw( carp croak ); |
|
18
|
|
|
|
|
60
|
|
|
18
|
|
|
|
|
1291
|
|
9
|
18
|
|
|
18
|
|
3819
|
use DBIx::Class::DeploymentHandler::LogImporter qw(:log :dlog); |
|
18
|
|
|
|
|
57
|
|
|
18
|
|
|
|
|
313
|
|
10
|
18
|
|
|
18
|
|
9327
|
use Context::Preserve; |
|
18
|
|
|
|
|
8888
|
|
|
18
|
|
|
|
|
896
|
|
11
|
18
|
|
|
18
|
|
144
|
use Digest::MD5; |
|
18
|
|
|
|
|
45
|
|
|
18
|
|
|
|
|
576
|
|
12
|
|
|
|
|
|
|
|
13
|
18
|
|
|
18
|
|
119
|
use Try::Tiny; |
|
18
|
|
|
|
|
116
|
|
|
18
|
|
|
|
|
1178
|
|
14
|
|
|
|
|
|
|
|
15
|
18
|
|
|
18
|
|
9179
|
use SQL::Translator; |
|
18
|
|
|
|
|
5406317
|
|
|
18
|
|
|
|
|
1086
|
|
16
|
|
|
|
|
|
|
require SQL::Translator::Diff; |
17
|
|
|
|
|
|
|
|
18
|
|
|
|
|
|
|
require DBIx::Class::Storage; # loaded for type constraint |
19
|
18
|
|
|
18
|
|
3911
|
use DBIx::Class::DeploymentHandler::Types; |
|
18
|
|
|
|
|
58
|
|
|
18
|
|
|
|
|
643
|
|
20
|
|
|
|
|
|
|
|
21
|
18
|
|
|
18
|
|
8001
|
use Path::Class qw(file dir); |
|
18
|
|
|
|
|
324067
|
|
|
18
|
|
|
|
|
78725
|
|
22
|
|
|
|
|
|
|
|
23
|
|
|
|
|
|
|
with 'DBIx::Class::DeploymentHandler::HandlesDeploy'; |
24
|
|
|
|
|
|
|
|
25
|
|
|
|
|
|
|
has ignore_ddl => ( |
26
|
|
|
|
|
|
|
isa => 'Bool', |
27
|
|
|
|
|
|
|
is => 'ro', |
28
|
|
|
|
|
|
|
default => undef, |
29
|
|
|
|
|
|
|
); |
30
|
|
|
|
|
|
|
|
31
|
|
|
|
|
|
|
has force_overwrite => ( |
32
|
|
|
|
|
|
|
isa => 'Bool', |
33
|
|
|
|
|
|
|
is => 'ro', |
34
|
|
|
|
|
|
|
default => undef, |
35
|
|
|
|
|
|
|
); |
36
|
|
|
|
|
|
|
|
37
|
|
|
|
|
|
|
has schema => ( |
38
|
|
|
|
|
|
|
is => 'ro', |
39
|
|
|
|
|
|
|
required => 1, |
40
|
|
|
|
|
|
|
); |
41
|
|
|
|
|
|
|
|
42
|
|
|
|
|
|
|
has storage => ( |
43
|
|
|
|
|
|
|
isa => 'DBIx::Class::Storage', |
44
|
|
|
|
|
|
|
is => 'ro', |
45
|
|
|
|
|
|
|
lazy_build => 1, |
46
|
|
|
|
|
|
|
); |
47
|
|
|
|
|
|
|
|
48
|
|
|
|
|
|
|
has version_source => ( |
49
|
|
|
|
|
|
|
is => 'ro', |
50
|
|
|
|
|
|
|
default => '__VERSION', |
51
|
|
|
|
|
|
|
); |
52
|
|
|
|
|
|
|
|
53
|
|
|
|
|
|
|
sub _build_storage { |
54
|
40
|
|
|
40
|
|
103
|
my $self = shift; |
55
|
40
|
|
|
|
|
1656
|
my $s = $self->schema->storage; |
56
|
40
|
|
|
|
|
940
|
$s->_determine_driver; |
57
|
40
|
|
|
|
|
28498
|
$s |
58
|
|
|
|
|
|
|
} |
59
|
|
|
|
|
|
|
|
60
|
|
|
|
|
|
|
has sql_translator_args => ( |
61
|
|
|
|
|
|
|
isa => 'HashRef', |
62
|
|
|
|
|
|
|
is => 'ro', |
63
|
|
|
|
|
|
|
default => sub { {} }, |
64
|
|
|
|
|
|
|
); |
65
|
|
|
|
|
|
|
has script_directory => ( |
66
|
|
|
|
|
|
|
isa => 'Str', |
67
|
|
|
|
|
|
|
is => 'ro', |
68
|
|
|
|
|
|
|
required => 1, |
69
|
|
|
|
|
|
|
default => 'sql', |
70
|
|
|
|
|
|
|
); |
71
|
|
|
|
|
|
|
|
72
|
|
|
|
|
|
|
has databases => ( |
73
|
|
|
|
|
|
|
coerce => 1, |
74
|
|
|
|
|
|
|
isa => 'DBIx::Class::DeploymentHandler::Databases', |
75
|
|
|
|
|
|
|
is => 'ro', |
76
|
|
|
|
|
|
|
default => sub { [qw( MySQL SQLite PostgreSQL )] }, |
77
|
|
|
|
|
|
|
); |
78
|
|
|
|
|
|
|
|
79
|
|
|
|
|
|
|
has txn_wrap => ( |
80
|
|
|
|
|
|
|
is => 'ro', |
81
|
|
|
|
|
|
|
isa => 'Bool', |
82
|
|
|
|
|
|
|
default => 1, |
83
|
|
|
|
|
|
|
); |
84
|
|
|
|
|
|
|
|
85
|
|
|
|
|
|
|
has schema_version => ( |
86
|
|
|
|
|
|
|
is => 'ro', |
87
|
|
|
|
|
|
|
lazy_build => 1, |
88
|
|
|
|
|
|
|
); |
89
|
|
|
|
|
|
|
|
90
|
|
|
|
|
|
|
# this will probably never get called as the DBICDH |
91
|
|
|
|
|
|
|
# will be passing down a schema_version normally, which |
92
|
|
|
|
|
|
|
# is built the same way, but we leave this in place |
93
|
|
|
|
|
|
|
sub _build_schema_version { |
94
|
13
|
|
|
13
|
|
43
|
my $self = shift; |
95
|
13
|
|
|
|
|
564
|
$self->schema->schema_version |
96
|
|
|
|
|
|
|
} |
97
|
|
|
|
|
|
|
|
98
|
|
|
|
|
|
|
sub __ddl_consume_with_prefix { |
99
|
42
|
|
|
42
|
|
181
|
my ($self, $type, $versions, $prefix) = @_; |
100
|
42
|
|
|
|
|
1909
|
my $base_dir = $self->script_directory; |
101
|
|
|
|
|
|
|
|
102
|
42
|
|
|
|
|
247
|
my $main = dir( $base_dir, $type ); |
103
|
|
|
|
|
|
|
my $common = |
104
|
42
|
|
|
|
|
3288
|
dir( $base_dir, '_common', $prefix, join q(-), @{$versions} ); |
|
42
|
|
|
|
|
228
|
|
105
|
|
|
|
|
|
|
|
106
|
42
|
|
|
|
|
1988
|
my $common_any = |
107
|
|
|
|
|
|
|
dir( $base_dir, '_common', $prefix, '_any' ); |
108
|
|
|
|
|
|
|
|
109
|
42
|
|
|
|
|
1850
|
my $dir_any = dir($main, $prefix, '_any'); |
110
|
|
|
|
|
|
|
|
111
|
42
|
|
|
|
|
1797
|
my %files; |
112
|
|
|
|
|
|
|
try { |
113
|
42
|
|
|
42
|
|
2061
|
my $dir = dir( $main, $prefix, join q(-), @{$versions} ); |
|
42
|
|
|
|
|
198
|
|
114
|
42
|
|
|
|
|
2016
|
opendir my($dh), $dir; |
115
|
|
|
|
|
|
|
%files = |
116
|
46
|
|
|
|
|
367
|
map { $_ => "$dir/$_" } |
117
|
37
|
100
|
|
|
|
14739
|
grep { /\.(?:sql|pl|sql-\w+)$/ && -f "$dir/$_" } |
|
120
|
|
|
|
|
2738
|
|
118
|
|
|
|
|
|
|
readdir $dh; |
119
|
37
|
|
|
|
|
883
|
closedir $dh; |
120
|
|
|
|
|
|
|
} catch { |
121
|
5
|
50
|
|
5
|
|
17410
|
die $_ unless $self->ignore_ddl; |
122
|
42
|
|
|
|
|
502
|
}; |
123
|
42
|
|
|
|
|
9356
|
for my $dirname (grep { -d $_ } $common, $common_any, $dir_any) { |
|
126
|
|
|
|
|
3224
|
|
124
|
17
|
|
|
|
|
788
|
opendir my($dh), $dirname; |
125
|
17
|
100
|
|
|
|
2079
|
for my $filename (grep { /\.(?:sql|pl)$/ && -f file($dirname,$_) } readdir $dh) { |
|
53
|
|
|
|
|
1860
|
|
126
|
19
|
50
|
|
|
|
1202
|
unless ($files{$filename}) { |
127
|
19
|
|
|
|
|
69
|
$files{$filename} = file($dirname,$filename); |
128
|
|
|
|
|
|
|
} |
129
|
|
|
|
|
|
|
} |
130
|
17
|
|
|
|
|
1188
|
closedir $dh; |
131
|
|
|
|
|
|
|
} |
132
|
|
|
|
|
|
|
|
133
|
42
|
|
|
|
|
2777
|
return [@files{sort keys %files}] |
134
|
|
|
|
|
|
|
} |
135
|
|
|
|
|
|
|
|
136
|
|
|
|
|
|
|
sub _ddl_initialize_consume_filenames { |
137
|
2
|
|
|
2
|
|
8
|
my ($self, $type, $version) = @_; |
138
|
2
|
|
|
|
|
18
|
$self->__ddl_consume_with_prefix($type, [ $version ], 'initialize') |
139
|
|
|
|
|
|
|
} |
140
|
|
|
|
|
|
|
|
141
|
|
|
|
|
|
|
sub _ddl_schema_consume_filenames { |
142
|
15
|
|
|
15
|
|
66
|
my ($self, $type, $version) = @_; |
143
|
15
|
|
|
|
|
99
|
$self->__ddl_consume_with_prefix($type, [ $version ], 'deploy') |
144
|
|
|
|
|
|
|
} |
145
|
|
|
|
|
|
|
|
146
|
|
|
|
|
|
|
sub _ddl_protoschema_deploy_consume_filenames { |
147
|
2
|
|
|
2
|
|
10
|
my ($self, $version) = @_; |
148
|
2
|
|
|
|
|
95
|
my $base_dir = $self->script_directory; |
149
|
|
|
|
|
|
|
|
150
|
2
|
|
|
|
|
14
|
my $dir = dir( $base_dir, '_source', 'deploy', $version); |
151
|
2
|
100
|
|
|
|
184
|
return [] unless -d $dir; |
152
|
|
|
|
|
|
|
|
153
|
1
|
|
|
|
|
78
|
opendir my($dh), $dir; |
154
|
1
|
100
|
|
|
|
886
|
my %files = map { $_ => "$dir/$_" } grep { /\.yml$/ && -f "$dir/$_" } readdir $dh; |
|
2
|
|
|
|
|
65
|
|
|
4
|
|
|
|
|
73
|
|
155
|
1
|
|
|
|
|
26
|
closedir $dh; |
156
|
|
|
|
|
|
|
|
157
|
1
|
|
|
|
|
655
|
return [@files{sort keys %files}] |
158
|
|
|
|
|
|
|
} |
159
|
|
|
|
|
|
|
|
160
|
|
|
|
|
|
|
sub _ddl_protoschema_upgrade_consume_filenames { |
161
|
19
|
|
|
19
|
|
73
|
my ($self, $versions) = @_; |
162
|
19
|
|
|
|
|
954
|
my $base_dir = $self->script_directory; |
163
|
|
|
|
|
|
|
|
164
|
19
|
|
|
|
|
72
|
my $dir = dir( $base_dir, '_preprocess_schema', 'upgrade', join q(-), @{$versions}); |
|
19
|
|
|
|
|
158
|
|
165
|
|
|
|
|
|
|
|
166
|
19
|
100
|
|
|
|
1891
|
return [] unless -d $dir; |
167
|
|
|
|
|
|
|
|
168
|
1
|
|
|
|
|
77
|
opendir my($dh), $dir; |
169
|
1
|
100
|
|
|
|
189
|
my %files = map { $_ => "$dir/$_" } grep { /\.pl$/ && -f "$dir/$_" } readdir $dh; |
|
1
|
|
|
|
|
6
|
|
|
3
|
|
|
|
|
67
|
|
170
|
1
|
|
|
|
|
28
|
closedir $dh; |
171
|
|
|
|
|
|
|
|
172
|
1
|
|
|
|
|
79
|
return [@files{sort keys %files}] |
173
|
|
|
|
|
|
|
} |
174
|
|
|
|
|
|
|
|
175
|
|
|
|
|
|
|
sub _ddl_protoschema_downgrade_consume_filenames { |
176
|
7
|
|
|
7
|
|
31
|
my ($self, $versions) = @_; |
177
|
7
|
|
|
|
|
341
|
my $base_dir = $self->script_directory; |
178
|
|
|
|
|
|
|
|
179
|
7
|
|
|
|
|
28
|
my $dir = dir( $base_dir, '_preprocess_schema', 'downgrade', join q(-), @{$versions}); |
|
7
|
|
|
|
|
60
|
|
180
|
|
|
|
|
|
|
|
181
|
7
|
50
|
|
|
|
703
|
return [] unless -d $dir; |
182
|
|
|
|
|
|
|
|
183
|
0
|
|
|
|
|
0
|
opendir my($dh), $dir; |
184
|
0
|
0
|
|
|
|
0
|
my %files = map { $_ => "$dir/$_" } grep { /\.pl$/ && -f "$dir/$_" } readdir $dh; |
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
185
|
0
|
|
|
|
|
0
|
closedir $dh; |
186
|
|
|
|
|
|
|
|
187
|
0
|
|
|
|
|
0
|
return [@files{sort keys %files}] |
188
|
|
|
|
|
|
|
} |
189
|
|
|
|
|
|
|
|
190
|
|
|
|
|
|
|
sub _ddl_protoschema_produce_filename { |
191
|
108
|
|
|
108
|
|
472
|
my ($self, $version) = @_; |
192
|
108
|
|
|
|
|
4749
|
my $dirname = dir( $self->script_directory, '_source', 'deploy', $version ); |
193
|
108
|
100
|
|
|
|
10637
|
$dirname->mkpath unless -d $dirname; |
194
|
|
|
|
|
|
|
|
195
|
108
|
|
|
|
|
15204
|
return "" . file( $dirname, '001-auto.yml' ); |
196
|
|
|
|
|
|
|
} |
197
|
|
|
|
|
|
|
|
198
|
|
|
|
|
|
|
sub _ddl_schema_produce_filename { |
199
|
21
|
|
|
21
|
|
121
|
my ($self, $type, $version) = @_; |
200
|
21
|
|
|
|
|
1046
|
my $dirname = dir( $self->script_directory, $type, 'deploy', $version ); |
201
|
21
|
50
|
|
|
|
2235
|
$dirname->mkpath unless -d $dirname; |
202
|
|
|
|
|
|
|
|
203
|
21
|
|
|
|
|
7712
|
return "" . file( $dirname, '001-auto.sql' ); |
204
|
|
|
|
|
|
|
} |
205
|
|
|
|
|
|
|
|
206
|
|
|
|
|
|
|
sub _ddl_schema_upgrade_consume_filenames { |
207
|
19
|
|
|
19
|
|
74
|
my ($self, $type, $versions) = @_; |
208
|
19
|
|
|
|
|
103
|
$self->__ddl_consume_with_prefix($type, $versions, 'upgrade') |
209
|
|
|
|
|
|
|
} |
210
|
|
|
|
|
|
|
|
211
|
|
|
|
|
|
|
sub _ddl_schema_downgrade_consume_filenames { |
212
|
6
|
|
|
6
|
|
27
|
my ($self, $type, $versions) = @_; |
213
|
6
|
|
|
|
|
34
|
$self->__ddl_consume_with_prefix($type, $versions, 'downgrade') |
214
|
|
|
|
|
|
|
} |
215
|
|
|
|
|
|
|
|
216
|
|
|
|
|
|
|
sub _ddl_schema_upgrade_produce_filename { |
217
|
18
|
|
|
18
|
|
75
|
my ($self, $type, $versions) = @_; |
218
|
18
|
|
|
|
|
899
|
my $dir = $self->script_directory; |
219
|
|
|
|
|
|
|
|
220
|
18
|
|
|
|
|
71
|
my $dirname = dir( $dir, $type, 'upgrade', join q(-), @{$versions}); |
|
18
|
|
|
|
|
112
|
|
221
|
18
|
100
|
|
|
|
1227
|
$dirname->mkpath unless -d $dirname; |
222
|
|
|
|
|
|
|
|
223
|
18
|
|
|
|
|
4782
|
return "" . file( $dirname, '001-auto.sql' ); |
224
|
|
|
|
|
|
|
} |
225
|
|
|
|
|
|
|
|
226
|
|
|
|
|
|
|
sub _ddl_schema_downgrade_produce_filename { |
227
|
6
|
|
|
6
|
|
27
|
my ($self, $type, $versions, $dir) = @_; |
228
|
6
|
|
|
|
|
20
|
my $dirname = dir( $dir, $type, 'downgrade', join q(-), @{$versions} ); |
|
6
|
|
|
|
|
38
|
|
229
|
6
|
100
|
|
|
|
448
|
$dirname->mkpath unless -d $dirname; |
230
|
|
|
|
|
|
|
|
231
|
6
|
|
|
|
|
1633
|
return "" . file( $dirname, '001-auto.sql'); |
232
|
|
|
|
|
|
|
} |
233
|
|
|
|
|
|
|
|
234
|
|
|
|
|
|
|
sub _run_sql_array { |
235
|
56
|
|
|
56
|
|
238
|
my ($self, $sql) = @_; |
236
|
56
|
|
|
|
|
2587
|
my $storage = $self->storage; |
237
|
|
|
|
|
|
|
|
238
|
56
|
|
|
|
|
277
|
$sql = [ $self->_split_sql_chunk( @$sql ) ]; |
239
|
|
|
|
|
|
|
|
240
|
56
|
|
|
0
|
|
433
|
Dlog_trace { "Running SQL $_" } $sql; |
|
0
|
|
|
|
|
0
|
|
241
|
56
|
|
|
|
|
1082
|
foreach my $line (@{$sql}) { |
|
56
|
|
|
|
|
193
|
|
242
|
99
|
|
|
|
|
778
|
$storage->_query_start($line); |
243
|
|
|
|
|
|
|
# the whole reason we do this is so that we can see the line that was run |
244
|
|
|
|
|
|
|
try { |
245
|
99
|
|
|
99
|
|
4687
|
$storage->dbh_do (sub { $_[1]->do($line) }); |
|
99
|
|
|
|
|
2973
|
|
246
|
|
|
|
|
|
|
} |
247
|
|
|
|
|
|
|
catch { |
248
|
3
|
|
|
3
|
|
4257
|
die "$_ (running line '$line')" |
249
|
99
|
|
|
|
|
1354
|
}; |
250
|
96
|
|
|
|
|
17739
|
$storage->_query_end($line); |
251
|
|
|
|
|
|
|
} |
252
|
53
|
|
|
|
|
688
|
return join "\n", @$sql |
253
|
|
|
|
|
|
|
} |
254
|
|
|
|
|
|
|
|
255
|
|
|
|
|
|
|
my %STORAGE2FEATURE = ( |
256
|
|
|
|
|
|
|
SQLServer => { |
257
|
|
|
|
|
|
|
txn => qr/begin\s+transaction\b/i, |
258
|
|
|
|
|
|
|
comment => { |
259
|
|
|
|
|
|
|
DD => 1, # -- |
260
|
|
|
|
|
|
|
HASH => 1, |
261
|
|
|
|
|
|
|
SSTAR => 1, # /* */ |
262
|
|
|
|
|
|
|
DS => 1, # // |
263
|
|
|
|
|
|
|
PERCENT => 1, |
264
|
|
|
|
|
|
|
}, |
265
|
|
|
|
|
|
|
}, |
266
|
|
|
|
|
|
|
Sybase => { |
267
|
|
|
|
|
|
|
txn => qr/begin\s+transaction\b/i, |
268
|
|
|
|
|
|
|
comment => { |
269
|
|
|
|
|
|
|
DD => 1, |
270
|
|
|
|
|
|
|
SSTAR => 1, |
271
|
|
|
|
|
|
|
DS => 1, |
272
|
|
|
|
|
|
|
PERCENT => 1, |
273
|
|
|
|
|
|
|
}, |
274
|
|
|
|
|
|
|
}, |
275
|
|
|
|
|
|
|
SQLite => { |
276
|
|
|
|
|
|
|
txn => qr/begin\b/i, |
277
|
|
|
|
|
|
|
comment => { |
278
|
|
|
|
|
|
|
DD => 1, |
279
|
|
|
|
|
|
|
HASH => 1, |
280
|
|
|
|
|
|
|
}, |
281
|
|
|
|
|
|
|
}, |
282
|
|
|
|
|
|
|
MySQL => { |
283
|
|
|
|
|
|
|
txn => qr/(begin\b|start\s+transaction\b)/i, |
284
|
|
|
|
|
|
|
comment => { |
285
|
|
|
|
|
|
|
DD => 1, |
286
|
|
|
|
|
|
|
HASH => 1, |
287
|
|
|
|
|
|
|
SS => 1, |
288
|
|
|
|
|
|
|
}, |
289
|
|
|
|
|
|
|
}, |
290
|
|
|
|
|
|
|
Oracle => { |
291
|
|
|
|
|
|
|
comment => { |
292
|
|
|
|
|
|
|
DD => 1, |
293
|
|
|
|
|
|
|
HASH => 1, |
294
|
|
|
|
|
|
|
SS => 1, |
295
|
|
|
|
|
|
|
}, |
296
|
|
|
|
|
|
|
}, |
297
|
|
|
|
|
|
|
Pg => { |
298
|
|
|
|
|
|
|
txn => qr/begin\b/i, |
299
|
|
|
|
|
|
|
chunk => sub { |
300
|
|
|
|
|
|
|
my ($c) = @_; |
301
|
|
|
|
|
|
|
my @ret; |
302
|
|
|
|
|
|
|
my $accumulator = ''; |
303
|
|
|
|
|
|
|
while (length $c) { |
304
|
|
|
|
|
|
|
if ($c =~ s/\A([^\$]*?);//s) { |
305
|
|
|
|
|
|
|
$accumulator .= $1; |
306
|
|
|
|
|
|
|
push @ret, $accumulator; |
307
|
|
|
|
|
|
|
$accumulator = ''; |
308
|
|
|
|
|
|
|
} elsif ( |
309
|
|
|
|
|
|
|
$c =~ s/\A( |
310
|
|
|
|
|
|
|
.*? |
311
|
|
|
|
|
|
|
( \$ [^\$]* \$ ) |
312
|
|
|
|
|
|
|
)//xs |
313
|
|
|
|
|
|
|
) { |
314
|
|
|
|
|
|
|
# got a $...$ .. $...$ chunk |
315
|
|
|
|
|
|
|
$accumulator .= $1; |
316
|
|
|
|
|
|
|
my $anchor = $2; |
317
|
|
|
|
|
|
|
$c =~ s/\A( |
318
|
|
|
|
|
|
|
.*? |
319
|
|
|
|
|
|
|
\Q$anchor\E |
320
|
|
|
|
|
|
|
)//xs; |
321
|
|
|
|
|
|
|
$accumulator .= $1; |
322
|
|
|
|
|
|
|
} elsif ($c =~ s/\A\s*\z//s) { |
323
|
|
|
|
|
|
|
push @ret, $accumulator; |
324
|
|
|
|
|
|
|
$accumulator = ''; |
325
|
|
|
|
|
|
|
} else { |
326
|
|
|
|
|
|
|
push @ret, $accumulator.$c; |
327
|
|
|
|
|
|
|
$accumulator = ''; |
328
|
|
|
|
|
|
|
last; |
329
|
|
|
|
|
|
|
} |
330
|
|
|
|
|
|
|
} |
331
|
|
|
|
|
|
|
@ret; |
332
|
|
|
|
|
|
|
}, |
333
|
|
|
|
|
|
|
comment => { |
334
|
|
|
|
|
|
|
DD => 1, |
335
|
|
|
|
|
|
|
HASH => 1, |
336
|
|
|
|
|
|
|
}, |
337
|
|
|
|
|
|
|
}, |
338
|
|
|
|
|
|
|
); |
339
|
|
|
|
|
|
|
|
340
|
|
|
|
|
|
|
# split a chunk o' SQL into statements |
341
|
|
|
|
|
|
|
sub _split_sql_chunk { |
342
|
111
|
|
|
111
|
|
513
|
my $self = shift; |
343
|
111
|
|
|
|
|
314
|
my @sql = map { $_.'' } @_; # copy |
|
171
|
|
|
|
|
689
|
|
344
|
111
|
|
|
|
|
4806
|
my $storage_class = ref $self->storage; |
345
|
111
|
|
|
|
|
515
|
$storage_class =~ s/.*://; |
346
|
111
|
|
33
|
|
|
528
|
my $feature = $STORAGE2FEATURE{$storage_class} || $STORAGE2FEATURE{MySQL}; |
347
|
111
|
|
|
|
|
324
|
for ( @sql ) { |
348
|
|
|
|
|
|
|
# strip transactions |
349
|
171
|
|
|
|
|
359
|
my $txn = $feature->{txn}; |
350
|
171
|
50
|
|
|
|
2139
|
s/^\s*($txn|COMMIT\b).*//mgi if $txn; |
351
|
|
|
|
|
|
|
# remove comments |
352
|
171
|
|
|
|
|
438
|
my $comment = $feature->{comment}; |
353
|
171
|
50
|
|
|
|
738
|
s{--.*}{}gm if $comment->{DD}; |
354
|
171
|
100
|
|
|
|
461
|
s{/\* .*? \*/}{}xs if $comment->{SS}; |
355
|
171
|
50
|
|
|
|
406
|
s{//.*}{}gm if $comment->{DS}; |
356
|
171
|
50
|
|
|
|
517
|
s{#.*}{}gm if $comment->{HASH}; |
357
|
171
|
50
|
|
|
|
554
|
s{%.*}{}gm if $comment->{PERCENT}; |
358
|
|
|
|
|
|
|
} |
359
|
111
|
|
100
|
169
|
|
807
|
my $chunk = $feature->{chunk} || sub { split /;\n/, $_[0] }; |
|
169
|
|
|
|
|
770
|
|
360
|
111
|
|
|
|
|
393
|
@sql = map $chunk->($_), @sql; |
361
|
111
|
|
|
|
|
298
|
for ( @sql ) { |
362
|
|
|
|
|
|
|
# trim whitespace |
363
|
376
|
|
|
|
|
1107
|
s/^\s+//gm; |
364
|
376
|
|
|
|
|
1132
|
s/\s+$//gm; |
365
|
|
|
|
|
|
|
# remove blank lines |
366
|
376
|
|
|
|
|
662
|
s/^\n//gm; |
367
|
|
|
|
|
|
|
# put on single line |
368
|
376
|
|
|
|
|
789
|
s/\n/ /g; |
369
|
|
|
|
|
|
|
} |
370
|
111
|
|
|
|
|
1569
|
return grep $_, @sql; |
371
|
|
|
|
|
|
|
} |
372
|
|
|
|
|
|
|
|
373
|
|
|
|
|
|
|
sub _run_sql { |
374
|
51
|
|
|
51
|
|
163
|
my ($self, $filename) = @_; |
375
|
51
|
|
|
0
|
|
468
|
log_debug { "Running SQL from $filename" }; |
|
0
|
|
|
|
|
0
|
|
376
|
|
|
|
|
|
|
try { |
377
|
51
|
|
|
51
|
|
2474
|
$self->_run_sql_array($self->_read_sql_file($filename)); |
378
|
|
|
|
|
|
|
} catch { |
379
|
3
|
|
|
3
|
|
110
|
die "failed to run SQL in $filename: $_" |
380
|
51
|
|
|
|
|
2214
|
}; |
381
|
|
|
|
|
|
|
} |
382
|
|
|
|
|
|
|
|
383
|
|
|
|
|
|
|
my ( %f2p, %p2f ); |
384
|
|
|
|
|
|
|
sub _generate_script_package_name { |
385
|
17
|
|
|
17
|
|
36
|
my $file = shift; |
386
|
|
|
|
|
|
|
|
387
|
17
|
|
|
|
|
38
|
my $pkgbase = 'DBICDH::Sandbox::'; |
388
|
17
|
|
|
|
|
36
|
my $maxlen = 200; # actual limit is "about 250" according to perldiag |
389
|
|
|
|
|
|
|
|
390
|
17
|
100
|
|
|
|
71
|
return $pkgbase . $f2p{"$file"} if $f2p{"$file"}; |
391
|
|
|
|
|
|
|
|
392
|
10
|
|
|
|
|
52
|
my $package = Digest::MD5::md5_hex("$file"); |
393
|
10
|
|
|
|
|
38
|
$package++ while exists $p2f{$package}; # increment until unique |
394
|
|
|
|
|
|
|
|
395
|
10
|
50
|
|
|
|
42
|
die "unable to generate a unique short name for '$file'" |
396
|
|
|
|
|
|
|
if length($pkgbase) + length($package) > $maxlen; |
397
|
|
|
|
|
|
|
|
398
|
10
|
|
|
|
|
33
|
$f2p{"$file"} = $package; |
399
|
10
|
|
|
|
|
31
|
$p2f{$package} = "$file"; |
400
|
|
|
|
|
|
|
|
401
|
10
|
|
|
|
|
36
|
return $pkgbase . $package; |
402
|
|
|
|
|
|
|
} |
403
|
|
|
|
|
|
|
|
404
|
|
|
|
|
|
|
sub _load_sandbox { |
405
|
17
|
|
|
17
|
|
43
|
my $_file = shift; |
406
|
17
|
|
|
|
|
52
|
$_file = "$_file"; |
407
|
|
|
|
|
|
|
|
408
|
17
|
|
|
|
|
477
|
my $_package = _generate_script_package_name($_file); |
409
|
|
|
|
|
|
|
|
410
|
17
|
|
|
|
|
2553
|
my $fn = eval sprintf <<'END_EVAL', $_package; |
411
|
|
|
|
|
|
|
package %s; |
412
|
|
|
|
|
|
|
{ |
413
|
|
|
|
|
|
|
our $app; |
414
|
|
|
|
|
|
|
$app ||= require $_file; |
415
|
|
|
|
|
|
|
if ( !$app && ( my $error = $@ || $! )) { die $error; } |
416
|
|
|
|
|
|
|
$app; |
417
|
|
|
|
|
|
|
} |
418
|
|
|
|
|
|
|
END_EVAL |
419
|
|
|
|
|
|
|
|
420
|
17
|
50
|
|
|
|
111
|
croak $@ if $@; |
421
|
|
|
|
|
|
|
|
422
|
17
|
50
|
33
|
|
|
104
|
croak "$_file should define an anonymous sub that takes a schema but it didn't!" |
423
|
|
|
|
|
|
|
unless ref $fn && ref $fn eq 'CODE'; |
424
|
|
|
|
|
|
|
|
425
|
17
|
|
|
|
|
49
|
return $fn; |
426
|
|
|
|
|
|
|
} |
427
|
|
|
|
|
|
|
|
428
|
|
|
|
|
|
|
sub _run_perl { |
429
|
17
|
|
|
17
|
|
1100
|
my ($self, $filename, $versions) = @_; |
430
|
17
|
|
|
0
|
|
127
|
log_debug { "Running Perl from $filename" }; |
|
0
|
|
|
|
|
0
|
|
431
|
|
|
|
|
|
|
|
432
|
17
|
|
|
|
|
614
|
my $fn = _load_sandbox($filename); |
433
|
|
|
|
|
|
|
|
434
|
17
|
|
|
0
|
|
129
|
Dlog_trace { "Running Perl $_" } $fn; |
|
0
|
|
|
|
|
0
|
|
435
|
|
|
|
|
|
|
|
436
|
|
|
|
|
|
|
try { |
437
|
17
|
|
|
17
|
|
1567
|
$fn->($self->schema, $versions) |
438
|
|
|
|
|
|
|
} catch { |
439
|
2
|
|
|
2
|
|
41
|
die "failed to run Perl in $filename: $_" |
440
|
17
|
|
|
|
|
396
|
}; |
441
|
|
|
|
|
|
|
} |
442
|
|
|
|
|
|
|
|
443
|
|
|
|
|
|
|
sub txn_do { |
444
|
73
|
|
|
73
|
0
|
669
|
my ( $self, $code ) = @_; |
445
|
73
|
100
|
|
|
|
3491
|
return $code->() unless $self->txn_wrap; |
446
|
|
|
|
|
|
|
|
447
|
71
|
|
|
|
|
2910
|
my $guard = $self->schema->txn_scope_guard; |
448
|
|
|
|
|
|
|
|
449
|
71
|
|
|
71
|
|
45177
|
return preserve_context { $code->() } after => sub { $guard->commit }; |
|
71
|
|
|
|
|
1116
|
|
|
68
|
|
|
|
|
20740
|
|
450
|
|
|
|
|
|
|
} |
451
|
|
|
|
|
|
|
|
452
|
|
|
|
|
|
|
sub _run_sql_and_perl { |
453
|
44
|
|
|
44
|
|
229
|
my ($self, $filenames, $sql_to_run, $versions) = @_; |
454
|
44
|
|
|
|
|
111
|
my @files = @{$filenames}; |
|
44
|
|
|
|
|
151
|
|
455
|
|
|
|
|
|
|
$self->txn_do(sub { |
456
|
44
|
100
|
|
44
|
|
2045
|
$self->_run_sql_array($sql_to_run) if $self->ignore_ddl; |
457
|
|
|
|
|
|
|
|
458
|
44
|
100
|
|
|
|
217
|
my $sql = ($sql_to_run)?join ";\n", @$sql_to_run:''; |
459
|
|
|
|
|
|
|
FILENAME: |
460
|
44
|
|
|
|
|
261
|
for my $filename (map file($_), @files) { |
461
|
66
|
50
|
66
|
|
|
10225
|
if ($self->ignore_ddl && $filename->basename =~ /^[^-]*-auto.*\.sql$/) { |
|
|
100
|
|
|
|
|
|
|
|
50
|
|
|
|
|
|
462
|
|
|
|
|
|
|
next FILENAME |
463
|
0
|
|
|
|
|
0
|
} elsif ($filename =~ /\.sql$/) { |
464
|
51
|
|
|
|
|
2191
|
$sql .= $self->_run_sql($filename) |
465
|
|
|
|
|
|
|
} elsif ( $filename =~ /\.pl$/ ) { |
466
|
15
|
|
|
|
|
1000
|
$self->_run_perl($filename, $versions) |
467
|
|
|
|
|
|
|
} else { |
468
|
0
|
|
|
|
|
0
|
croak "A file ($filename) got to deploy that wasn't sql or perl!"; |
469
|
|
|
|
|
|
|
} |
470
|
|
|
|
|
|
|
} |
471
|
|
|
|
|
|
|
|
472
|
40
|
|
|
|
|
4400
|
return $sql; |
473
|
44
|
|
|
|
|
386
|
}); |
474
|
|
|
|
|
|
|
} |
475
|
|
|
|
|
|
|
|
476
|
|
|
|
|
|
|
sub deploy { |
477
|
17
|
|
|
17
|
1
|
59101
|
my $self = shift; |
478
|
17
|
|
66
|
|
|
479
|
my $version = (shift @_ || {})->{version} || $self->schema_version; |
479
|
17
|
|
|
0
|
|
171
|
log_info { "deploying version $version" }; |
|
0
|
|
|
|
|
0
|
|
480
|
17
|
|
|
|
|
1732
|
my $sqlt_type = $self->storage->sqlt_type; |
481
|
17
|
|
|
|
|
7777
|
my $sql; |
482
|
17
|
|
|
|
|
810
|
my $sqltargs = $self->sql_translator_args; |
483
|
17
|
100
|
|
|
|
728
|
if ($self->ignore_ddl) { |
484
|
2
|
|
|
|
|
13
|
$sql = $self->_sql_from_yaml($sqltargs, |
485
|
|
|
|
|
|
|
'_ddl_protoschema_deploy_consume_filenames', $sqlt_type |
486
|
|
|
|
|
|
|
); |
487
|
|
|
|
|
|
|
} |
488
|
17
|
|
|
|
|
110
|
return $self->_run_sql_and_perl($self->_ddl_schema_consume_filenames( |
489
|
|
|
|
|
|
|
$sqlt_type, |
490
|
|
|
|
|
|
|
$version, |
491
|
|
|
|
|
|
|
), $sql, [$version]); |
492
|
|
|
|
|
|
|
} |
493
|
|
|
|
|
|
|
|
494
|
|
|
|
|
|
|
sub initialize { |
495
|
2
|
|
|
2
|
1
|
920
|
my $self = shift; |
496
|
2
|
|
|
|
|
13
|
my $args = shift; |
497
|
2
|
|
33
|
|
|
13
|
my $version = $args->{version} || $self->schema_version; |
498
|
2
|
|
|
0
|
|
23
|
log_info { "initializing version $version" }; |
|
0
|
|
|
|
|
0
|
|
499
|
2
|
|
66
|
|
|
186
|
my $storage_type = $args->{storage_type} || $self->storage->sqlt_type; |
500
|
|
|
|
|
|
|
|
501
|
2
|
|
|
|
|
672
|
my @files = @{$self->_ddl_initialize_consume_filenames( |
|
2
|
|
|
|
|
11
|
|
502
|
|
|
|
|
|
|
$storage_type, |
503
|
|
|
|
|
|
|
$version, |
504
|
|
|
|
|
|
|
)}; |
505
|
|
|
|
|
|
|
|
506
|
2
|
|
|
|
|
13
|
for my $filename (@files) { |
507
|
|
|
|
|
|
|
# We ignore sql for now (till I figure out what to do with it) |
508
|
3
|
50
|
|
|
|
21
|
if ( $filename =~ /^(.+)\.pl$/ ) { |
509
|
3
|
|
|
|
|
87
|
my $filedata = do { local( @ARGV, $/ ) = $filename; <> }; |
|
3
|
|
|
|
|
18
|
|
|
3
|
|
|
|
|
81
|
|
510
|
|
|
|
|
|
|
|
511
|
18
|
|
|
18
|
|
221
|
no warnings 'redefine'; |
|
18
|
|
|
|
|
48
|
|
|
18
|
|
|
|
|
1315
|
|
512
|
3
|
|
|
1
|
|
490
|
my $fn = eval "$filedata"; |
|
1
|
|
|
1
|
|
11
|
|
|
1
|
|
|
|
|
73
|
|
|
1
|
|
|
|
|
120
|
|
|
1
|
|
|
|
|
49
|
|
|
1
|
|
|
|
|
4
|
|
|
1
|
|
|
|
|
108
|
|
513
|
18
|
|
|
18
|
|
143
|
use warnings; |
|
18
|
|
|
|
|
70
|
|
|
18
|
|
|
|
|
31140
|
|
514
|
|
|
|
|
|
|
|
515
|
3
|
50
|
|
|
|
23
|
if ($@) { |
|
|
50
|
|
|
|
|
|
516
|
0
|
|
|
|
|
0
|
croak "$filename failed to compile: $@"; |
517
|
|
|
|
|
|
|
} elsif (ref $fn eq 'CODE') { |
518
|
3
|
|
|
|
|
102
|
$fn->() |
519
|
|
|
|
|
|
|
} else { |
520
|
0
|
|
|
|
|
0
|
croak "$filename should define an anonymous sub but it didn't!"; |
521
|
|
|
|
|
|
|
} |
522
|
|
|
|
|
|
|
} else { |
523
|
0
|
|
|
|
|
0
|
croak "A file ($filename) got to initialize_scripts that wasn't sql or perl!"; |
524
|
|
|
|
|
|
|
} |
525
|
|
|
|
|
|
|
} |
526
|
|
|
|
|
|
|
} |
527
|
|
|
|
|
|
|
|
528
|
|
|
|
|
|
|
sub _sqldiff_from_yaml { |
529
|
26
|
|
|
26
|
|
126
|
my ($self, $from_version, $to_version, $db, $direction) = @_; |
530
|
26
|
|
|
|
|
1135
|
my $dir = $self->script_directory; |
531
|
|
|
|
|
|
|
my $sqltargs = { |
532
|
|
|
|
|
|
|
add_drop_table => 0, |
533
|
|
|
|
|
|
|
ignore_constraint_names => 1, |
534
|
|
|
|
|
|
|
ignore_index_names => 1, |
535
|
26
|
|
|
|
|
106
|
%{$self->sql_translator_args} |
|
26
|
|
|
|
|
1167
|
|
536
|
|
|
|
|
|
|
}; |
537
|
|
|
|
|
|
|
|
538
|
26
|
|
|
|
|
82
|
my $source_schema; |
539
|
|
|
|
|
|
|
{ |
540
|
26
|
|
|
|
|
59
|
my $prefilename = $self->_ddl_protoschema_produce_filename($from_version, $dir); |
|
26
|
|
|
|
|
299
|
|
541
|
|
|
|
|
|
|
|
542
|
|
|
|
|
|
|
# should probably be a croak |
543
|
26
|
100
|
|
|
|
3647
|
carp("No previous schema file found ($prefilename)") |
544
|
|
|
|
|
|
|
unless -e $prefilename; |
545
|
|
|
|
|
|
|
|
546
|
|
|
|
|
|
|
my $t = SQL::Translator->new({ |
547
|
26
|
|
|
|
|
219
|
%{$sqltargs}, |
|
26
|
|
|
|
|
1037
|
|
548
|
|
|
|
|
|
|
debug => 0, |
549
|
|
|
|
|
|
|
trace => 0, |
550
|
|
|
|
|
|
|
parser => 'SQL::Translator::Parser::YAML', |
551
|
|
|
|
|
|
|
}); |
552
|
|
|
|
|
|
|
|
553
|
26
|
50
|
|
|
|
27521
|
my $out = $t->translate( $prefilename ) |
554
|
|
|
|
|
|
|
or croak($t->error); |
555
|
|
|
|
|
|
|
|
556
|
26
|
|
|
|
|
1068952
|
$source_schema = $t->schema; |
557
|
|
|
|
|
|
|
|
558
|
26
|
50
|
|
|
|
1776
|
$source_schema->name( $prefilename ) |
559
|
|
|
|
|
|
|
unless $source_schema->name; |
560
|
|
|
|
|
|
|
} |
561
|
|
|
|
|
|
|
|
562
|
26
|
|
|
|
|
87
|
my $dest_schema; |
563
|
|
|
|
|
|
|
{ |
564
|
26
|
|
|
|
|
65
|
my $filename = $self->_ddl_protoschema_produce_filename($to_version, $dir); |
|
26
|
|
|
|
|
166
|
|
565
|
|
|
|
|
|
|
|
566
|
|
|
|
|
|
|
# should probably be a croak |
567
|
26
|
50
|
|
|
|
3794
|
carp("No next schema file found ($filename)") |
568
|
|
|
|
|
|
|
unless -e $filename; |
569
|
|
|
|
|
|
|
|
570
|
|
|
|
|
|
|
my $t = SQL::Translator->new({ |
571
|
26
|
|
|
|
|
247
|
%{$sqltargs}, |
|
26
|
|
|
|
|
1024
|
|
572
|
|
|
|
|
|
|
debug => 0, |
573
|
|
|
|
|
|
|
trace => 0, |
574
|
|
|
|
|
|
|
parser => 'SQL::Translator::Parser::YAML', |
575
|
|
|
|
|
|
|
}); |
576
|
|
|
|
|
|
|
|
577
|
26
|
50
|
|
|
|
25776
|
my $out = $t->translate( $filename ) |
578
|
|
|
|
|
|
|
or croak($t->error); |
579
|
|
|
|
|
|
|
|
580
|
26
|
|
|
|
|
1162357
|
$dest_schema = $t->schema; |
581
|
|
|
|
|
|
|
|
582
|
26
|
50
|
|
|
|
1449
|
$dest_schema->name( $filename ) |
583
|
|
|
|
|
|
|
unless $dest_schema->name; |
584
|
|
|
|
|
|
|
} |
585
|
|
|
|
|
|
|
|
586
|
26
|
|
|
|
|
143
|
my $transform_files_method = "_ddl_protoschema_${direction}_consume_filenames"; |
587
|
26
|
|
|
|
|
289
|
my $transforms = $self->_coderefs_per_files( |
588
|
|
|
|
|
|
|
$self->$transform_files_method([$from_version, $to_version]) |
589
|
|
|
|
|
|
|
); |
590
|
26
|
|
|
|
|
154
|
$_->($source_schema, $dest_schema) for @$transforms; |
591
|
|
|
|
|
|
|
|
592
|
26
|
|
|
|
|
718
|
return [SQL::Translator::Diff::schema_diff( |
593
|
|
|
|
|
|
|
$source_schema, $db, |
594
|
|
|
|
|
|
|
$dest_schema, $db, |
595
|
|
|
|
|
|
|
{ producer_args => $sqltargs } |
596
|
|
|
|
|
|
|
)]; |
597
|
|
|
|
|
|
|
} |
598
|
|
|
|
|
|
|
|
599
|
|
|
|
|
|
|
sub _sql_from_yaml { |
600
|
46
|
|
|
46
|
|
218
|
my ($self, $sqltargs, $from_file, $db) = @_; |
601
|
46
|
|
|
|
|
1931
|
my $schema = $self->schema; |
602
|
46
|
|
|
|
|
1815
|
my $version = $self->schema_version; |
603
|
|
|
|
|
|
|
|
604
|
46
|
|
|
|
|
143
|
my @sql; |
605
|
|
|
|
|
|
|
|
606
|
46
|
|
|
|
|
285
|
my $actual_file = $self->$from_file($version); |
607
|
46
|
|
|
|
|
5726
|
for my $yaml_filename (@{( |
608
|
0
|
|
|
0
|
|
0
|
DlogS_trace { "generating SQL from Serialized SQL Files: $_" } |
609
|
46
|
100
|
|
|
|
595
|
(ref $actual_file?$actual_file:[$actual_file]) |
610
|
|
|
|
|
|
|
)}) { |
611
|
|
|
|
|
|
|
my $sqlt = SQL::Translator->new({ |
612
|
|
|
|
|
|
|
add_drop_table => 0, |
613
|
|
|
|
|
|
|
parser => 'SQL::Translator::Parser::YAML', |
614
|
46
|
|
|
|
|
1261
|
%{$sqltargs}, |
|
46
|
|
|
|
|
1429
|
|
615
|
|
|
|
|
|
|
producer => $db, |
616
|
|
|
|
|
|
|
}); |
617
|
|
|
|
|
|
|
|
618
|
46
|
|
|
|
|
384023
|
push @sql, $sqlt->translate($yaml_filename); |
619
|
46
|
50
|
|
|
|
2690883
|
if(!@sql) { |
620
|
0
|
|
|
|
|
0
|
carp("Failed to translate to $db, skipping. (" . $sqlt->error . ")"); |
621
|
0
|
|
|
|
|
0
|
return undef; |
622
|
|
|
|
|
|
|
} |
623
|
|
|
|
|
|
|
} |
624
|
46
|
|
|
|
|
595
|
return \@sql; |
625
|
|
|
|
|
|
|
} |
626
|
|
|
|
|
|
|
|
627
|
|
|
|
|
|
|
sub _prepare_install { |
628
|
50
|
|
|
50
|
|
181
|
my $self = shift; |
629
|
50
|
|
|
|
|
135
|
my $sqltargs = { %{$self->sql_translator_args}, %{shift @_} }; |
|
50
|
|
|
|
|
2763
|
|
|
50
|
|
|
|
|
226
|
|
630
|
50
|
|
|
|
|
159
|
my $from_file = shift; |
631
|
50
|
|
|
|
|
139
|
my $to_file = shift; |
632
|
50
|
|
|
|
|
2246
|
my $dir = $self->script_directory; |
633
|
50
|
|
|
|
|
2129
|
my $databases = $self->databases; |
634
|
50
|
|
|
|
|
2149
|
my $version = $self->schema_version; |
635
|
|
|
|
|
|
|
|
636
|
50
|
|
|
|
|
295
|
foreach my $db (@$databases) { |
637
|
44
|
50
|
|
|
|
260
|
my $sql = $self->_sql_from_yaml($sqltargs, $from_file, $db ) or next; |
638
|
|
|
|
|
|
|
|
639
|
44
|
|
|
|
|
344
|
my $filename = $self->$to_file($db, $version, $dir); |
640
|
44
|
50
|
|
|
|
6572
|
if (-e $filename ) { |
641
|
0
|
0
|
|
|
|
0
|
if ($self->force_overwrite) { |
642
|
0
|
|
|
|
|
0
|
carp "Overwriting existing DDL file - $filename"; |
643
|
0
|
|
|
|
|
0
|
unlink $filename; |
644
|
|
|
|
|
|
|
} else { |
645
|
0
|
|
|
|
|
0
|
die "Cannot overwrite '$filename', either enable force_overwrite or delete it" |
646
|
|
|
|
|
|
|
} |
647
|
|
|
|
|
|
|
} |
648
|
44
|
|
|
|
|
432
|
open my $file, q(>), $filename; |
649
|
44
|
|
|
|
|
8183
|
binmode $file; |
650
|
44
|
|
|
|
|
2105
|
print {$file} join ";\n", @$sql, ''; |
|
44
|
|
|
|
|
1263
|
|
651
|
44
|
|
|
|
|
279
|
close $file; |
652
|
|
|
|
|
|
|
} |
653
|
|
|
|
|
|
|
} |
654
|
|
|
|
|
|
|
|
655
|
|
|
|
|
|
|
sub _resultsource_install_filename { |
656
|
23
|
|
|
23
|
|
1919
|
my ($self, $source_name) = @_; |
657
|
|
|
|
|
|
|
return sub { |
658
|
20
|
|
|
20
|
|
1512
|
my ($self, $type, $version) = @_; |
659
|
20
|
|
|
|
|
989
|
my $dirname = dir( $self->script_directory, $type, 'deploy', $version ); |
660
|
20
|
100
|
|
|
|
2161
|
$dirname->mkpath unless -d $dirname; |
661
|
|
|
|
|
|
|
|
662
|
20
|
|
|
|
|
2232
|
return "" . file( $dirname, "001-auto-$source_name.sql" ); |
663
|
|
|
|
|
|
|
} |
664
|
23
|
|
|
|
|
144
|
} |
665
|
|
|
|
|
|
|
|
666
|
|
|
|
|
|
|
sub _resultsource_protoschema_filename { |
667
|
21
|
|
|
21
|
|
72
|
my ($self, $source_name) = @_; |
668
|
|
|
|
|
|
|
return sub { |
669
|
39
|
|
|
39
|
|
129
|
my ($self, $version) = @_; |
670
|
39
|
|
|
|
|
1510
|
my $dirname = dir( $self->script_directory, '_source', 'deploy', $version ); |
671
|
39
|
100
|
|
|
|
3777
|
$dirname->mkpath unless -d $dirname; |
672
|
|
|
|
|
|
|
|
673
|
39
|
|
|
|
|
2718
|
return "" . file( $dirname, "001-auto-$source_name.yml" ); |
674
|
|
|
|
|
|
|
} |
675
|
21
|
|
|
|
|
107
|
} |
676
|
|
|
|
|
|
|
|
677
|
|
|
|
|
|
|
sub install_resultsource { |
678
|
2
|
|
|
2
|
0
|
21
|
my ($self, $args) = @_; |
679
|
|
|
|
|
|
|
my $source = $args->{result_source} |
680
|
2
|
50
|
|
|
|
13
|
or die 'result_source must be passed to install_resultsource'; |
681
|
|
|
|
|
|
|
my $version = $args->{version} |
682
|
2
|
50
|
|
|
|
9
|
or die 'version must be passed to install_resultsource'; |
683
|
2
|
|
|
0
|
|
20
|
log_info { 'installing_resultsource ' . $source->source_name . ", version $version" }; |
|
0
|
|
|
|
|
0
|
|
684
|
2
|
|
|
|
|
125
|
my $rs_install_file = |
685
|
|
|
|
|
|
|
$self->_resultsource_install_filename($source->source_name); |
686
|
|
|
|
|
|
|
|
687
|
2
|
|
|
|
|
89
|
my $files = [ |
688
|
|
|
|
|
|
|
$self->$rs_install_file( |
689
|
|
|
|
|
|
|
$self->storage->sqlt_type, |
690
|
|
|
|
|
|
|
$version, |
691
|
|
|
|
|
|
|
) |
692
|
|
|
|
|
|
|
]; |
693
|
2
|
|
|
|
|
275
|
$self->_run_sql_and_perl($files, [], [$version]); |
694
|
|
|
|
|
|
|
} |
695
|
|
|
|
|
|
|
|
696
|
|
|
|
|
|
|
sub prepare_resultsource_install { |
697
|
21
|
|
|
21
|
0
|
333
|
my $self = shift; |
698
|
21
|
|
|
|
|
82
|
my $source = (shift @_)->{result_source}; |
699
|
21
|
|
|
0
|
|
205
|
log_info { 'preparing install for resultsource ' . $source->source_name }; |
|
0
|
|
|
|
|
0
|
|
700
|
|
|
|
|
|
|
|
701
|
21
|
|
|
|
|
1570
|
my $install_filename = $self->_resultsource_install_filename($source->source_name); |
702
|
21
|
|
|
|
|
121
|
my $proto_filename = $self->_resultsource_protoschema_filename($source->source_name); |
703
|
21
|
|
|
|
|
217
|
$self->prepare_protoschema({ |
704
|
|
|
|
|
|
|
parser_args => { sources => [$source->source_name], } |
705
|
|
|
|
|
|
|
}, $proto_filename); |
706
|
21
|
|
|
|
|
5105
|
$self->_prepare_install({}, $proto_filename, $install_filename); |
707
|
|
|
|
|
|
|
} |
708
|
|
|
|
|
|
|
|
709
|
|
|
|
|
|
|
sub prepare_deploy { |
710
|
0
|
|
|
0
|
0
|
0
|
log_info { 'preparing deploy' }; |
|
30
|
|
|
30
|
|
3472
|
|
711
|
30
|
|
|
|
|
1824
|
my $self = shift; |
712
|
|
|
|
|
|
|
$self->prepare_protoschema({ |
713
|
|
|
|
|
|
|
# Exclude version table so that it gets installed separately |
714
|
|
|
|
|
|
|
parser_args => { |
715
|
|
|
|
|
|
|
sources => [ |
716
|
3
|
|
|
|
|
37
|
sort { $a cmp $b } |
717
|
30
|
|
|
|
|
1441
|
grep { $_ ne $self->version_source } |
|
55
|
|
|
|
|
3528
|
|
718
|
|
|
|
|
|
|
$self->schema->sources |
719
|
|
|
|
|
|
|
], |
720
|
|
|
|
|
|
|
} |
721
|
|
|
|
|
|
|
}, '_ddl_protoschema_produce_filename'); |
722
|
29
|
|
|
|
|
14205
|
$self->_prepare_install({}, '_ddl_protoschema_produce_filename', '_ddl_schema_produce_filename'); |
723
|
|
|
|
|
|
|
} |
724
|
|
|
|
|
|
|
|
725
|
|
|
|
|
|
|
sub prepare_upgrade { |
726
|
18
|
|
|
18
|
0
|
4569
|
my ($self, $args) = @_; |
727
|
|
|
|
|
|
|
log_info { |
728
|
0
|
|
|
0
|
|
0
|
"preparing upgrade from $args->{from_version} to $args->{to_version}" |
729
|
18
|
|
|
|
|
198
|
}; |
730
|
|
|
|
|
|
|
$self->_prepare_changegrade( |
731
|
18
|
|
|
|
|
1357
|
$args->{from_version}, $args->{to_version}, $args->{version_set}, 'upgrade' |
732
|
|
|
|
|
|
|
); |
733
|
|
|
|
|
|
|
} |
734
|
|
|
|
|
|
|
|
735
|
|
|
|
|
|
|
sub prepare_downgrade { |
736
|
6
|
|
|
6
|
0
|
2308
|
my ($self, $args) = @_; |
737
|
|
|
|
|
|
|
log_info { |
738
|
0
|
|
|
0
|
|
0
|
"preparing downgrade from $args->{from_version} to $args->{to_version}" |
739
|
6
|
|
|
|
|
97
|
}; |
740
|
|
|
|
|
|
|
$self->_prepare_changegrade( |
741
|
6
|
|
|
|
|
370
|
$args->{from_version}, $args->{to_version}, $args->{version_set}, 'downgrade' |
742
|
|
|
|
|
|
|
); |
743
|
|
|
|
|
|
|
} |
744
|
|
|
|
|
|
|
|
745
|
|
|
|
|
|
|
sub _coderefs_per_files { |
746
|
26
|
|
|
26
|
|
1707
|
my ($self, $files) = @_; |
747
|
18
|
|
|
18
|
|
172
|
no warnings 'redefine'; |
|
18
|
|
|
|
|
60
|
|
|
18
|
|
|
|
|
17008
|
|
748
|
26
|
|
|
|
|
120
|
[map eval do { local( @ARGV, $/ ) = $_; <> }, @$files] |
|
1
|
|
|
|
|
9
|
|
|
1
|
|
|
|
|
312
|
|
749
|
|
|
|
|
|
|
} |
750
|
|
|
|
|
|
|
|
751
|
|
|
|
|
|
|
sub _prepare_changegrade { |
752
|
24
|
|
|
24
|
|
118
|
my ($self, $from_version, $to_version, $version_set, $direction) = @_; |
753
|
24
|
|
|
|
|
1113
|
my $schema = $self->schema; |
754
|
24
|
|
|
|
|
1021
|
my $databases = $self->databases; |
755
|
24
|
|
|
|
|
1000
|
my $dir = $self->script_directory; |
756
|
|
|
|
|
|
|
|
757
|
24
|
|
|
|
|
1280
|
my $schema_version = $self->schema_version; |
758
|
24
|
|
|
|
|
107
|
my $diff_file_method = "_ddl_schema_${direction}_produce_filename"; |
759
|
24
|
|
|
|
|
94
|
foreach my $db (@$databases) { |
760
|
24
|
|
|
|
|
159
|
my $diff_file = $self->$diff_file_method($db, $version_set, $dir ); |
761
|
24
|
100
|
|
|
|
3345
|
if(-e $diff_file) { |
762
|
1
|
50
|
|
|
|
58
|
if ($self->force_overwrite) { |
763
|
0
|
|
|
|
|
0
|
carp("Overwriting existing $direction-diff file - $diff_file"); |
764
|
0
|
|
|
|
|
0
|
unlink $diff_file; |
765
|
|
|
|
|
|
|
} else { |
766
|
1
|
|
|
|
|
15
|
die "Cannot overwrite '$diff_file', either enable force_overwrite or delete it" |
767
|
|
|
|
|
|
|
} |
768
|
|
|
|
|
|
|
} |
769
|
|
|
|
|
|
|
|
770
|
23
|
|
|
|
|
199
|
open my $file, q(>), $diff_file; |
771
|
23
|
|
|
|
|
3194
|
binmode $file; |
772
|
23
|
|
|
|
|
973
|
print {$file} join ";\n", @{$self->_sqldiff_from_yaml($from_version, $to_version, $db, $direction)}; |
|
23
|
|
|
|
|
162
|
|
|
23
|
|
|
|
|
158
|
|
773
|
23
|
|
|
|
|
461720
|
close $file; |
774
|
|
|
|
|
|
|
} |
775
|
|
|
|
|
|
|
} |
776
|
|
|
|
|
|
|
|
777
|
|
|
|
|
|
|
sub _read_sql_file { |
778
|
51
|
|
|
51
|
|
167
|
my ($self, $file) = @_; |
779
|
51
|
50
|
|
|
|
226
|
return unless $file; |
780
|
|
|
|
|
|
|
|
781
|
51
|
|
|
|
|
524
|
local $/ = undef; #sluuuuuurp |
782
|
|
|
|
|
|
|
|
783
|
51
|
|
|
|
|
327
|
open my $fh, '<', $file; |
784
|
51
|
|
|
|
|
15355
|
return [ $self->_split_sql_chunk( <$fh> ) ]; |
785
|
|
|
|
|
|
|
} |
786
|
|
|
|
|
|
|
|
787
|
|
|
|
|
|
|
sub downgrade_single_step { |
788
|
6
|
|
|
6
|
0
|
19143
|
my $self = shift; |
789
|
6
|
|
|
|
|
27
|
my $version_set = (shift @_)->{version_set}; |
790
|
6
|
|
|
0
|
|
58
|
Dlog_info { "downgrade_single_step'ing $_" } $version_set; |
|
0
|
|
|
|
|
0
|
|
791
|
|
|
|
|
|
|
|
792
|
6
|
|
|
|
|
599
|
my $sqlt_type = $self->storage->sqlt_type; |
793
|
6
|
|
|
|
|
242
|
my $sql_to_run; |
794
|
6
|
100
|
|
|
|
274
|
if ($self->ignore_ddl) { |
795
|
1
|
|
|
|
|
6
|
$sql_to_run = $self->_sqldiff_from_yaml( |
796
|
|
|
|
|
|
|
$version_set->[0], $version_set->[1], $sqlt_type, 'downgrade', |
797
|
|
|
|
|
|
|
); |
798
|
|
|
|
|
|
|
} |
799
|
6
|
|
|
|
|
32305
|
my $sql = $self->_run_sql_and_perl($self->_ddl_schema_downgrade_consume_filenames( |
800
|
|
|
|
|
|
|
$sqlt_type, |
801
|
|
|
|
|
|
|
$version_set, |
802
|
|
|
|
|
|
|
), $sql_to_run, $version_set); |
803
|
|
|
|
|
|
|
|
804
|
6
|
|
|
|
|
718
|
return ['', $sql]; |
805
|
|
|
|
|
|
|
} |
806
|
|
|
|
|
|
|
|
807
|
|
|
|
|
|
|
sub upgrade_single_step { |
808
|
19
|
|
|
19
|
0
|
40475
|
my $self = shift; |
809
|
19
|
|
|
|
|
68
|
my $version_set = (shift @_)->{version_set}; |
810
|
19
|
|
|
0
|
|
182
|
Dlog_info { "upgrade_single_step'ing $_" } $version_set; |
|
0
|
|
|
|
|
0
|
|
811
|
|
|
|
|
|
|
|
812
|
19
|
|
|
|
|
2007
|
my $sqlt_type = $self->storage->sqlt_type; |
813
|
19
|
|
|
|
|
916
|
my $sql_to_run; |
814
|
19
|
100
|
|
|
|
887
|
if ($self->ignore_ddl) { |
815
|
2
|
|
|
|
|
13
|
$sql_to_run = $self->_sqldiff_from_yaml( |
816
|
|
|
|
|
|
|
$version_set->[0], $version_set->[1], $sqlt_type, 'upgrade', |
817
|
|
|
|
|
|
|
); |
818
|
|
|
|
|
|
|
} |
819
|
19
|
|
|
|
|
34947
|
my $sql = $self->_run_sql_and_perl($self->_ddl_schema_upgrade_consume_filenames( |
820
|
|
|
|
|
|
|
$sqlt_type, |
821
|
|
|
|
|
|
|
$version_set, |
822
|
|
|
|
|
|
|
), $sql_to_run, $version_set); |
823
|
18
|
|
|
|
|
2378
|
return ['', $sql]; |
824
|
|
|
|
|
|
|
} |
825
|
|
|
|
|
|
|
|
826
|
|
|
|
|
|
|
sub prepare_protoschema { |
827
|
51
|
|
|
51
|
0
|
134
|
my $self = shift; |
828
|
51
|
|
|
|
|
121
|
my $sqltargs = { %{$self->sql_translator_args}, %{shift @_} }; |
|
51
|
|
|
|
|
2402
|
|
|
51
|
|
|
|
|
234
|
|
829
|
51
|
|
|
|
|
146
|
my $to_file = shift; |
830
|
51
|
|
|
|
|
2208
|
my $filename |
831
|
|
|
|
|
|
|
= $self->$to_file($self->schema_version); |
832
|
|
|
|
|
|
|
|
833
|
|
|
|
|
|
|
# we do this because the code that uses this sets parser args, |
834
|
|
|
|
|
|
|
# so we just need to merge in the package |
835
|
|
|
|
|
|
|
my $sqlt = SQL::Translator->new({ |
836
|
|
|
|
|
|
|
parser => 'SQL::Translator::Parser::DBIx::Class', |
837
|
|
|
|
|
|
|
producer => 'SQL::Translator::Producer::YAML', |
838
|
51
|
|
|
|
|
7009
|
%{ $sqltargs }, |
|
51
|
|
|
|
|
1812
|
|
839
|
|
|
|
|
|
|
}); |
840
|
|
|
|
|
|
|
|
841
|
51
|
|
|
|
|
233266
|
my $yml = $sqlt->translate(data => $self->schema); |
842
|
|
|
|
|
|
|
|
843
|
51
|
50
|
|
|
|
1971971
|
croak("Failed to translate to YAML: " . $sqlt->error) |
844
|
|
|
|
|
|
|
unless $yml; |
845
|
|
|
|
|
|
|
|
846
|
51
|
100
|
|
|
|
2581
|
if (-e $filename ) { |
847
|
1
|
50
|
|
|
|
66
|
if ($self->force_overwrite) { |
848
|
0
|
|
|
|
|
0
|
carp "Overwriting existing DDL-YML file - $filename"; |
849
|
0
|
|
|
|
|
0
|
unlink $filename; |
850
|
|
|
|
|
|
|
} else { |
851
|
1
|
|
|
|
|
45
|
die "Cannot overwrite '$filename', either enable force_overwrite or delete it" |
852
|
|
|
|
|
|
|
} |
853
|
|
|
|
|
|
|
} |
854
|
|
|
|
|
|
|
|
855
|
50
|
|
|
|
|
504
|
open my $file, q(>), $filename; |
856
|
50
|
|
|
|
|
37009
|
binmode $file; |
857
|
50
|
|
|
|
|
14211
|
print {$file} $yml; |
|
50
|
|
|
|
|
1123
|
|
858
|
50
|
|
|
|
|
361
|
close $file; |
859
|
|
|
|
|
|
|
} |
860
|
|
|
|
|
|
|
|
861
|
|
|
|
|
|
|
__PACKAGE__->meta->make_immutable; |
862
|
|
|
|
|
|
|
|
863
|
|
|
|
|
|
|
1; |
864
|
|
|
|
|
|
|
|
865
|
|
|
|
|
|
|
# vim: ts=2 sw=2 expandtab |
866
|
|
|
|
|
|
|
|
867
|
|
|
|
|
|
|
__END__ |
868
|
|
|
|
|
|
|
|
869
|
|
|
|
|
|
|
=pod |
870
|
|
|
|
|
|
|
|
871
|
|
|
|
|
|
|
=head1 NAME |
872
|
|
|
|
|
|
|
|
873
|
|
|
|
|
|
|
DBIx::Class::DeploymentHandler::DeployMethod::SQL::Translator - Manage your SQL and Perl migrations in nicely laid out directories |
874
|
|
|
|
|
|
|
|
875
|
|
|
|
|
|
|
=head1 DESCRIPTION |
876
|
|
|
|
|
|
|
|
877
|
|
|
|
|
|
|
This class is the meat of L<DBIx::Class::DeploymentHandler>. It takes care |
878
|
|
|
|
|
|
|
of generating serialized schemata as well as sql files to move from one |
879
|
|
|
|
|
|
|
version of a schema to the rest. One of the hallmark features of this class |
880
|
|
|
|
|
|
|
is that it allows for multiple sql files for deploy and upgrade, allowing |
881
|
|
|
|
|
|
|
developers to fine tune deployment. In addition it also allows for perl |
882
|
|
|
|
|
|
|
files to be run at any stage of the process. |
883
|
|
|
|
|
|
|
|
884
|
|
|
|
|
|
|
For basic usage see L<DBIx::Class::DeploymentHandler::HandlesDeploy>. What's |
885
|
|
|
|
|
|
|
documented here is extra fun stuff or private methods. |
886
|
|
|
|
|
|
|
|
887
|
|
|
|
|
|
|
=head1 DIRECTORY LAYOUT |
888
|
|
|
|
|
|
|
|
889
|
|
|
|
|
|
|
Arguably this is the best feature of L<DBIx::Class::DeploymentHandler>. |
890
|
|
|
|
|
|
|
It's spiritually based upon L<DBIx::Migration::Directories>, but has a |
891
|
|
|
|
|
|
|
lot of extensions and modifications, so even if you are familiar with it, |
892
|
|
|
|
|
|
|
please read this. I feel like the best way to describe the layout is with |
893
|
|
|
|
|
|
|
the following example: |
894
|
|
|
|
|
|
|
|
895
|
|
|
|
|
|
|
$sql_migration_dir |
896
|
|
|
|
|
|
|
|- _source |
897
|
|
|
|
|
|
|
| |- deploy |
898
|
|
|
|
|
|
|
| |- 1 |
899
|
|
|
|
|
|
|
| | `- 001-auto.yml |
900
|
|
|
|
|
|
|
| |- 2 |
901
|
|
|
|
|
|
|
| | `- 001-auto.yml |
902
|
|
|
|
|
|
|
| `- 3 |
903
|
|
|
|
|
|
|
| `- 001-auto.yml |
904
|
|
|
|
|
|
|
|- SQLite |
905
|
|
|
|
|
|
|
| |- downgrade |
906
|
|
|
|
|
|
|
| | `- 2-1 |
907
|
|
|
|
|
|
|
| | `- 001-auto.sql |
908
|
|
|
|
|
|
|
| |- deploy |
909
|
|
|
|
|
|
|
| | `- 1 |
910
|
|
|
|
|
|
|
| | `- 001-auto.sql |
911
|
|
|
|
|
|
|
| `- upgrade |
912
|
|
|
|
|
|
|
| |- 1-2 |
913
|
|
|
|
|
|
|
| | `- 001-auto.sql |
914
|
|
|
|
|
|
|
| `- 2-3 |
915
|
|
|
|
|
|
|
| `- 001-auto.sql |
916
|
|
|
|
|
|
|
|- _common |
917
|
|
|
|
|
|
|
| |- downgrade |
918
|
|
|
|
|
|
|
| | `- 2-1 |
919
|
|
|
|
|
|
|
| | `- 002-remove-customers.pl |
920
|
|
|
|
|
|
|
| `- upgrade |
921
|
|
|
|
|
|
|
| `- 1-2 |
922
|
|
|
|
|
|
|
| | `- 002-generate-customers.pl |
923
|
|
|
|
|
|
|
| `- _any |
924
|
|
|
|
|
|
|
| `- 999-bump-action.pl |
925
|
|
|
|
|
|
|
`- MySQL |
926
|
|
|
|
|
|
|
|- downgrade |
927
|
|
|
|
|
|
|
| `- 2-1 |
928
|
|
|
|
|
|
|
| `- 001-auto.sql |
929
|
|
|
|
|
|
|
|- initialize |
930
|
|
|
|
|
|
|
| `- 1 |
931
|
|
|
|
|
|
|
| |- 001-create_database.pl |
932
|
|
|
|
|
|
|
| `- 002-create_users_and_permissions.pl |
933
|
|
|
|
|
|
|
|- deploy |
934
|
|
|
|
|
|
|
| `- 1 |
935
|
|
|
|
|
|
|
| `- 001-auto.sql |
936
|
|
|
|
|
|
|
`- upgrade |
937
|
|
|
|
|
|
|
`- 1-2 |
938
|
|
|
|
|
|
|
`- 001-auto.sql |
939
|
|
|
|
|
|
|
|
940
|
|
|
|
|
|
|
So basically, the code |
941
|
|
|
|
|
|
|
|
942
|
|
|
|
|
|
|
$dm->deploy(1) |
943
|
|
|
|
|
|
|
|
944
|
|
|
|
|
|
|
on an C<SQLite> database that would simply run |
945
|
|
|
|
|
|
|
C<$sql_migration_dir/SQLite/deploy/1/001-auto.sql>. Next, |
946
|
|
|
|
|
|
|
|
947
|
|
|
|
|
|
|
$dm->upgrade_single_step([1,2]) |
948
|
|
|
|
|
|
|
|
949
|
|
|
|
|
|
|
would run C<$sql_migration_dir/SQLite/upgrade/1-2/001-auto.sql> followed by |
950
|
|
|
|
|
|
|
C<$sql_migration_dir/_common/upgrade/1-2/002-generate-customers.pl>, and |
951
|
|
|
|
|
|
|
finally punctuated by |
952
|
|
|
|
|
|
|
C<$sql_migration_dir/_common/upgrade/_any/999-bump-action.pl>. |
953
|
|
|
|
|
|
|
|
954
|
|
|
|
|
|
|
C<.pl> files don't have to be in the C<_common> directory, but most of the time |
955
|
|
|
|
|
|
|
they should be, because perl scripts are generally database independent. |
956
|
|
|
|
|
|
|
|
957
|
|
|
|
|
|
|
Note that unlike most steps in the process, C<initialize> will not run SQL, as |
958
|
|
|
|
|
|
|
there may not even be an database at initialize time. It will run perl scripts |
959
|
|
|
|
|
|
|
just like the other steps in the process, but nothing is passed to them. |
960
|
|
|
|
|
|
|
Until people have used this more it will remain freeform, but a recommended use |
961
|
|
|
|
|
|
|
of initialize is to have it prompt for username and password, and then call the |
962
|
|
|
|
|
|
|
appropriate C<< CREATE DATABASE >> commands etc. |
963
|
|
|
|
|
|
|
|
964
|
|
|
|
|
|
|
=head2 Directory Specification |
965
|
|
|
|
|
|
|
|
966
|
|
|
|
|
|
|
The following subdirectories are recognized by this DeployMethod: |
967
|
|
|
|
|
|
|
|
968
|
|
|
|
|
|
|
=over 2 |
969
|
|
|
|
|
|
|
|
970
|
|
|
|
|
|
|
=item C<_source> |
971
|
|
|
|
|
|
|
|
972
|
|
|
|
|
|
|
This directory can contain the following directories: |
973
|
|
|
|
|
|
|
|
974
|
|
|
|
|
|
|
=over 2 |
975
|
|
|
|
|
|
|
|
976
|
|
|
|
|
|
|
=item C<deploy> |
977
|
|
|
|
|
|
|
|
978
|
|
|
|
|
|
|
This directory merely contains directories named after schema |
979
|
|
|
|
|
|
|
versions, which in turn contain C<yaml> files that are serialized versions |
980
|
|
|
|
|
|
|
of the schema at that version. These files are not for editing by hand. |
981
|
|
|
|
|
|
|
|
982
|
|
|
|
|
|
|
=back |
983
|
|
|
|
|
|
|
|
984
|
|
|
|
|
|
|
=item C<_preprocess_schema> |
985
|
|
|
|
|
|
|
|
986
|
|
|
|
|
|
|
This directory can contain the following directories: |
987
|
|
|
|
|
|
|
|
988
|
|
|
|
|
|
|
=over 2 |
989
|
|
|
|
|
|
|
|
990
|
|
|
|
|
|
|
=item C<downgrade> |
991
|
|
|
|
|
|
|
|
992
|
|
|
|
|
|
|
This directory merely contains directories named after migrations, which are of |
993
|
|
|
|
|
|
|
the form C<$from_version-$to_version>. Inside of these directories you may put |
994
|
|
|
|
|
|
|
Perl scripts which are to return a subref that takes the arguments C<< |
995
|
|
|
|
|
|
|
$from_schema, $to_schema >>, which are L<SQL::Translator::Schema> objects. |
996
|
|
|
|
|
|
|
|
997
|
|
|
|
|
|
|
=item C<upgrade> |
998
|
|
|
|
|
|
|
|
999
|
|
|
|
|
|
|
This directory merely contains directories named after migrations, which are of |
1000
|
|
|
|
|
|
|
the form C<$from_version-$to_version>. Inside of these directories you may put |
1001
|
|
|
|
|
|
|
Perl scripts which are to return a subref that takes the arguments C<< |
1002
|
|
|
|
|
|
|
$from_schema, $to_schema >>, which are L<SQL::Translator::Schema> objects. |
1003
|
|
|
|
|
|
|
|
1004
|
|
|
|
|
|
|
=back |
1005
|
|
|
|
|
|
|
|
1006
|
|
|
|
|
|
|
A typical usage of C<_preprocess_schema> is to define indices or other non-DBIC |
1007
|
|
|
|
|
|
|
type metadata. Here is an example of how one might do that: |
1008
|
|
|
|
|
|
|
|
1009
|
|
|
|
|
|
|
The following coderef could be placed in a file called |
1010
|
|
|
|
|
|
|
F<_preprocess_schema/1-2/001-add-user-index.pl> |
1011
|
|
|
|
|
|
|
|
1012
|
|
|
|
|
|
|
sub { |
1013
|
|
|
|
|
|
|
my ($from, $to) = @_; |
1014
|
|
|
|
|
|
|
|
1015
|
|
|
|
|
|
|
$to->get_table('Users')->add_index( |
1016
|
|
|
|
|
|
|
name => 'idx_Users_name', |
1017
|
|
|
|
|
|
|
fields => ['name'], |
1018
|
|
|
|
|
|
|
) |
1019
|
|
|
|
|
|
|
} |
1020
|
|
|
|
|
|
|
|
1021
|
|
|
|
|
|
|
This would ensure that in version 2 of the schema the generated migrations |
1022
|
|
|
|
|
|
|
include an index on C<< Users.name >>. Frustratingly, due to the nature of |
1023
|
|
|
|
|
|
|
L<SQL::Translator>, you'll need to add this to each migration or it will detect |
1024
|
|
|
|
|
|
|
that it was left out and kindly remove the index for you. |
1025
|
|
|
|
|
|
|
|
1026
|
|
|
|
|
|
|
An alternative to the above, which is likely to be a lot less annoying, is to |
1027
|
|
|
|
|
|
|
define such data in your schema directly, and only change it as you need to: |
1028
|
|
|
|
|
|
|
|
1029
|
|
|
|
|
|
|
package MyApp::Schema::Result::User; |
1030
|
|
|
|
|
|
|
|
1031
|
|
|
|
|
|
|
#[...] |
1032
|
|
|
|
|
|
|
|
1033
|
|
|
|
|
|
|
sub sqlt_deploy_hook ( $self, $sqlt_table ) { |
1034
|
|
|
|
|
|
|
$sqlt_table->add_index(name => 'idx_Users_name', fields => [ 'name' ]); |
1035
|
|
|
|
|
|
|
} |
1036
|
|
|
|
|
|
|
|
1037
|
|
|
|
|
|
|
=item C<$storage_type> |
1038
|
|
|
|
|
|
|
|
1039
|
|
|
|
|
|
|
This is a set of scripts that gets run depending on what your storage type is. |
1040
|
|
|
|
|
|
|
If you are not sure what your storage type is, take a look at the producers |
1041
|
|
|
|
|
|
|
listed for L<SQL::Translator>. Also note, C<_common> is a special case. |
1042
|
|
|
|
|
|
|
C<_common> will get merged into whatever other files you already have. This |
1043
|
|
|
|
|
|
|
directory can contain the following directories itself: |
1044
|
|
|
|
|
|
|
|
1045
|
|
|
|
|
|
|
=over 2 |
1046
|
|
|
|
|
|
|
|
1047
|
|
|
|
|
|
|
=item C<initialize> |
1048
|
|
|
|
|
|
|
|
1049
|
|
|
|
|
|
|
If you are using the C<initialize> functionality, |
1050
|
|
|
|
|
|
|
you should call initialize() before calling C<install>. This has the same structure as the |
1051
|
|
|
|
|
|
|
C<deploy> subdirectory as well; that is, it has a directory for each schema |
1052
|
|
|
|
|
|
|
version. Unlike C<deploy>, C<upgrade>, and C<downgrade> though, it can only run |
1053
|
|
|
|
|
|
|
C<.pl> files, and the coderef in the perl files get no arguments passed to them. |
1054
|
|
|
|
|
|
|
|
1055
|
|
|
|
|
|
|
=item C<deploy> |
1056
|
|
|
|
|
|
|
|
1057
|
|
|
|
|
|
|
Gets run when the schema is C<deploy>ed. Structure is a directory per schema |
1058
|
|
|
|
|
|
|
version, and then files are merged with C<_common> and run in filename order. |
1059
|
|
|
|
|
|
|
C<.sql> files are merely run, as expected. C<.pl> files are run according to |
1060
|
|
|
|
|
|
|
L</PERL SCRIPTS>. |
1061
|
|
|
|
|
|
|
|
1062
|
|
|
|
|
|
|
=item C<upgrade> |
1063
|
|
|
|
|
|
|
|
1064
|
|
|
|
|
|
|
Gets run when the schema is C<upgrade>d. Structure is a directory per upgrade |
1065
|
|
|
|
|
|
|
step, (for example, C<1-2> for upgrading from version 1 to version 2,) and then |
1066
|
|
|
|
|
|
|
files are merged with C<_common> and run in filename order. C<.sql> files are |
1067
|
|
|
|
|
|
|
merely run, as expected. C<.pl> files are run according to L</PERL SCRIPTS>. |
1068
|
|
|
|
|
|
|
|
1069
|
|
|
|
|
|
|
=item C<downgrade> |
1070
|
|
|
|
|
|
|
|
1071
|
|
|
|
|
|
|
Gets run when the schema is C<downgrade>d. Structure is a directory per |
1072
|
|
|
|
|
|
|
downgrade step, (for example, C<2-1> for downgrading from version 2 to version |
1073
|
|
|
|
|
|
|
1,) and then files are merged with C<_common> and run in filename order. |
1074
|
|
|
|
|
|
|
C<.sql> files are merely run, as expected. C<.pl> files are run according to |
1075
|
|
|
|
|
|
|
L</PERL SCRIPTS>. |
1076
|
|
|
|
|
|
|
|
1077
|
|
|
|
|
|
|
=back |
1078
|
|
|
|
|
|
|
|
1079
|
|
|
|
|
|
|
=back |
1080
|
|
|
|
|
|
|
|
1081
|
|
|
|
|
|
|
Note that there can be an C<_any> in the place of any of the versions (like |
1082
|
|
|
|
|
|
|
C<1-2> or C<1>), which means those scripts will be run B<every> time. So if |
1083
|
|
|
|
|
|
|
you have an C<_any> in C<_common/upgrade>, that script will get run for every |
1084
|
|
|
|
|
|
|
upgrade. |
1085
|
|
|
|
|
|
|
|
1086
|
|
|
|
|
|
|
=head1 PERL SCRIPTS |
1087
|
|
|
|
|
|
|
|
1088
|
|
|
|
|
|
|
A perl script for this tool is very simple. It merely needs to contain an |
1089
|
|
|
|
|
|
|
anonymous sub that takes a L<DBIx::Class::Schema> and the version set as it's |
1090
|
|
|
|
|
|
|
arguments. |
1091
|
|
|
|
|
|
|
|
1092
|
|
|
|
|
|
|
A very basic perl script might look like: |
1093
|
|
|
|
|
|
|
|
1094
|
|
|
|
|
|
|
#!perl |
1095
|
|
|
|
|
|
|
|
1096
|
|
|
|
|
|
|
use strict; |
1097
|
|
|
|
|
|
|
use warnings; |
1098
|
|
|
|
|
|
|
|
1099
|
|
|
|
|
|
|
use DBIx::Class::DeploymentHandler::DeployMethod::SQL::Translator::ScriptHelpers |
1100
|
|
|
|
|
|
|
'schema_from_schema_loader'; |
1101
|
|
|
|
|
|
|
|
1102
|
|
|
|
|
|
|
schema_from_schema_loader({ naming => 'v4' }, sub { |
1103
|
|
|
|
|
|
|
my $schema = shift; |
1104
|
|
|
|
|
|
|
|
1105
|
|
|
|
|
|
|
# [1] for deploy, [1,2] for upgrade or downgrade, probably used with _any |
1106
|
|
|
|
|
|
|
my $versions = shift; |
1107
|
|
|
|
|
|
|
|
1108
|
|
|
|
|
|
|
$schema->resultset('Users')->create({ |
1109
|
|
|
|
|
|
|
name => 'root', |
1110
|
|
|
|
|
|
|
password => 'root', |
1111
|
|
|
|
|
|
|
}) |
1112
|
|
|
|
|
|
|
}) |
1113
|
|
|
|
|
|
|
|
1114
|
|
|
|
|
|
|
Note that the above uses |
1115
|
|
|
|
|
|
|
L<DBIx::Class::DeploymentHandler::DeployMethod::SQL::Translator::ScriptHelpers/schema_from_schema_loader>. |
1116
|
|
|
|
|
|
|
Using a raw coderef is strongly discouraged as it is likely to break as you |
1117
|
|
|
|
|
|
|
modify your schema. |
1118
|
|
|
|
|
|
|
|
1119
|
|
|
|
|
|
|
=head1 SEE ALSO |
1120
|
|
|
|
|
|
|
|
1121
|
|
|
|
|
|
|
This class is an implementation of |
1122
|
|
|
|
|
|
|
L<DBIx::Class::DeploymentHandler::HandlesDeploy>. Pretty much all the |
1123
|
|
|
|
|
|
|
documentation is there. |
1124
|
|
|
|
|
|
|
|
1125
|
|
|
|
|
|
|
=head1 ATTRIBUTES |
1126
|
|
|
|
|
|
|
|
1127
|
|
|
|
|
|
|
=head2 ignore_ddl |
1128
|
|
|
|
|
|
|
|
1129
|
|
|
|
|
|
|
This attribute will, when set to true (default is false), cause the DM to use |
1130
|
|
|
|
|
|
|
L<SQL::Translator> to use the C<_source>'s serialized SQL::Translator::Schema |
1131
|
|
|
|
|
|
|
instead of any pregenerated SQL. If you have a development server this is |
1132
|
|
|
|
|
|
|
probably the best plan of action as you will not be putting as many generated |
1133
|
|
|
|
|
|
|
files in your version control. Goes well with with C<databases> of C<[]>. |
1134
|
|
|
|
|
|
|
|
1135
|
|
|
|
|
|
|
=head2 force_overwrite |
1136
|
|
|
|
|
|
|
|
1137
|
|
|
|
|
|
|
When this attribute is true generated files will be overwritten when the |
1138
|
|
|
|
|
|
|
methods which create such files are run again. The default is false, in which |
1139
|
|
|
|
|
|
|
case the program will die with a message saying which file needs to be deleted. |
1140
|
|
|
|
|
|
|
|
1141
|
|
|
|
|
|
|
=head2 schema |
1142
|
|
|
|
|
|
|
|
1143
|
|
|
|
|
|
|
The L<DBIx::Class::Schema> (B<required>) that is used to talk to the database |
1144
|
|
|
|
|
|
|
and generate the DDL. |
1145
|
|
|
|
|
|
|
|
1146
|
|
|
|
|
|
|
=head2 storage |
1147
|
|
|
|
|
|
|
|
1148
|
|
|
|
|
|
|
The L<DBIx::Class::Storage> that is I<actually> used to talk to the database |
1149
|
|
|
|
|
|
|
and generate the DDL. This is automatically created with L</_build_storage>. |
1150
|
|
|
|
|
|
|
|
1151
|
|
|
|
|
|
|
=head2 sql_translator_args |
1152
|
|
|
|
|
|
|
|
1153
|
|
|
|
|
|
|
The arguments that get passed to L<SQL::Translator> when it's used. |
1154
|
|
|
|
|
|
|
|
1155
|
|
|
|
|
|
|
=head2 script_directory |
1156
|
|
|
|
|
|
|
|
1157
|
|
|
|
|
|
|
The directory (default C<'sql'>) that scripts are stored in |
1158
|
|
|
|
|
|
|
|
1159
|
|
|
|
|
|
|
=head2 databases |
1160
|
|
|
|
|
|
|
|
1161
|
|
|
|
|
|
|
The types of databases (default C<< [qw( MySQL SQLite PostgreSQL )] >>) to |
1162
|
|
|
|
|
|
|
generate files for |
1163
|
|
|
|
|
|
|
|
1164
|
|
|
|
|
|
|
=head2 txn_wrap |
1165
|
|
|
|
|
|
|
|
1166
|
|
|
|
|
|
|
Set to true (which is the default) to wrap all upgrades and deploys in a single |
1167
|
|
|
|
|
|
|
transaction. |
1168
|
|
|
|
|
|
|
|
1169
|
|
|
|
|
|
|
=head2 schema_version |
1170
|
|
|
|
|
|
|
|
1171
|
|
|
|
|
|
|
The version the schema on your harddrive is at. Defaults to |
1172
|
|
|
|
|
|
|
C<< $self->schema->schema_version >>. |
1173
|
|
|
|
|
|
|
|
1174
|
|
|
|
|
|
|
=head2 version_source |
1175
|
|
|
|
|
|
|
|
1176
|
|
|
|
|
|
|
The source name used to register the version storage with C<schema>. Defaults |
1177
|
|
|
|
|
|
|
to C<__VERSION>. |
1178
|
|
|
|
|
|
|
|
1179
|
|
|
|
|
|
|
=head1 AUTHOR |
1180
|
|
|
|
|
|
|
|
1181
|
|
|
|
|
|
|
Arthur Axel "fREW" Schmidt <frioux+cpan@gmail.com> |
1182
|
|
|
|
|
|
|
|
1183
|
|
|
|
|
|
|
=head1 COPYRIGHT AND LICENSE |
1184
|
|
|
|
|
|
|
|
1185
|
|
|
|
|
|
|
This software is copyright (c) 2019 by Arthur Axel "fREW" Schmidt. |
1186
|
|
|
|
|
|
|
|
1187
|
|
|
|
|
|
|
This is free software; you can redistribute it and/or modify it under |
1188
|
|
|
|
|
|
|
the same terms as the Perl 5 programming language system itself. |
1189
|
|
|
|
|
|
|
|
1190
|
|
|
|
|
|
|
=cut |