line |
stmt |
bran |
cond |
sub |
pod |
time |
code |
1
|
|
|
|
|
|
|
package # Hide from PAUSE |
2
|
|
|
|
|
|
|
DBIx::Class::Version::Table; |
3
|
3
|
|
|
3
|
|
25280
|
use base 'DBIx::Class::Core'; |
|
3
|
|
|
|
|
9
|
|
|
3
|
|
|
|
|
521
|
|
4
|
3
|
|
|
3
|
|
25
|
use strict; |
|
3
|
|
|
|
|
8
|
|
|
3
|
|
|
|
|
77
|
|
5
|
3
|
|
|
3
|
|
18
|
use warnings; |
|
3
|
|
|
|
|
7
|
|
|
3
|
|
|
|
|
305
|
|
6
|
|
|
|
|
|
|
|
7
|
|
|
|
|
|
|
__PACKAGE__->table('dbix_class_schema_versions'); |
8
|
|
|
|
|
|
|
|
9
|
|
|
|
|
|
|
__PACKAGE__->add_columns |
10
|
|
|
|
|
|
|
( 'version' => { |
11
|
|
|
|
|
|
|
'data_type' => 'VARCHAR', |
12
|
|
|
|
|
|
|
'is_auto_increment' => 0, |
13
|
|
|
|
|
|
|
'default_value' => undef, |
14
|
|
|
|
|
|
|
'is_foreign_key' => 0, |
15
|
|
|
|
|
|
|
'name' => 'version', |
16
|
|
|
|
|
|
|
'is_nullable' => 0, |
17
|
|
|
|
|
|
|
'size' => '10' |
18
|
|
|
|
|
|
|
}, |
19
|
|
|
|
|
|
|
'installed' => { |
20
|
|
|
|
|
|
|
'data_type' => 'VARCHAR', |
21
|
|
|
|
|
|
|
'is_auto_increment' => 0, |
22
|
|
|
|
|
|
|
'default_value' => undef, |
23
|
|
|
|
|
|
|
'is_foreign_key' => 0, |
24
|
|
|
|
|
|
|
'name' => 'installed', |
25
|
|
|
|
|
|
|
'is_nullable' => 0, |
26
|
|
|
|
|
|
|
'size' => '20' |
27
|
|
|
|
|
|
|
}, |
28
|
|
|
|
|
|
|
); |
29
|
|
|
|
|
|
|
__PACKAGE__->result_source_instance->set_primary_key('version'); |
30
|
|
|
|
|
|
|
|
31
|
|
|
|
|
|
|
package # Hide from PAUSE |
32
|
|
|
|
|
|
|
DBIx::Class::Version::TableCompat; |
33
|
3
|
|
|
3
|
|
21
|
use base 'DBIx::Class::Core'; |
|
3
|
|
|
|
|
6
|
|
|
3
|
|
|
|
|
422
|
|
34
|
|
|
|
|
|
|
__PACKAGE__->table('SchemaVersions'); |
35
|
|
|
|
|
|
|
|
36
|
|
|
|
|
|
|
__PACKAGE__->add_columns |
37
|
|
|
|
|
|
|
( 'Version' => { |
38
|
|
|
|
|
|
|
'data_type' => 'VARCHAR', |
39
|
|
|
|
|
|
|
}, |
40
|
|
|
|
|
|
|
'Installed' => { |
41
|
|
|
|
|
|
|
'data_type' => 'VARCHAR', |
42
|
|
|
|
|
|
|
}, |
43
|
|
|
|
|
|
|
); |
44
|
|
|
|
|
|
|
__PACKAGE__->result_source_instance->set_primary_key('Version'); |
45
|
|
|
|
|
|
|
|
46
|
|
|
|
|
|
|
package # Hide from PAUSE |
47
|
|
|
|
|
|
|
DBIx::Class::Version; |
48
|
3
|
|
|
3
|
|
20
|
use base 'DBIx::Class::Schema'; |
|
3
|
|
|
|
|
8
|
|
|
3
|
|
|
|
|
223
|
|
49
|
3
|
|
|
3
|
|
19
|
use strict; |
|
3
|
|
|
|
|
7
|
|
|
3
|
|
|
|
|
56
|
|
50
|
3
|
|
|
3
|
|
13
|
use warnings; |
|
3
|
|
|
|
|
10
|
|
|
3
|
|
|
|
|
165
|
|
51
|
|
|
|
|
|
|
|
52
|
|
|
|
|
|
|
# no point sanity checking, unless we are running asserts |
53
|
|
|
|
|
|
|
__PACKAGE__->schema_sanity_checker( |
54
|
|
|
|
|
|
|
DBIx::Class::_ENV_::ASSERT_NO_FAILING_SANITY_CHECKS |
55
|
|
|
|
|
|
|
? 'DBIx::Class::Schema::SanityChecker' |
56
|
|
|
|
|
|
|
: '' |
57
|
|
|
|
|
|
|
); |
58
|
|
|
|
|
|
|
|
59
|
|
|
|
|
|
|
__PACKAGE__->register_class('Table', 'DBIx::Class::Version::Table'); |
60
|
|
|
|
|
|
|
|
61
|
|
|
|
|
|
|
package # Hide from PAUSE |
62
|
|
|
|
|
|
|
DBIx::Class::VersionCompat; |
63
|
3
|
|
|
3
|
|
15
|
use base 'DBIx::Class::Schema'; |
|
3
|
|
|
|
|
5
|
|
|
3
|
|
|
|
|
212
|
|
64
|
3
|
|
|
3
|
|
17
|
use strict; |
|
3
|
|
|
|
|
4
|
|
|
3
|
|
|
|
|
54
|
|
65
|
3
|
|
|
3
|
|
18
|
use warnings; |
|
3
|
|
|
|
|
6
|
|
|
3
|
|
|
|
|
231
|
|
66
|
|
|
|
|
|
|
|
67
|
|
|
|
|
|
|
# no point sanity checking, unless we are running asserts |
68
|
|
|
|
|
|
|
__PACKAGE__->schema_sanity_checker( |
69
|
|
|
|
|
|
|
DBIx::Class::_ENV_::ASSERT_NO_FAILING_SANITY_CHECKS |
70
|
|
|
|
|
|
|
? 'DBIx::Class::Schema::SanityChecker' |
71
|
|
|
|
|
|
|
: '' |
72
|
|
|
|
|
|
|
); |
73
|
|
|
|
|
|
|
|
74
|
|
|
|
|
|
|
__PACKAGE__->register_class('TableCompat', 'DBIx::Class::Version::TableCompat'); |
75
|
|
|
|
|
|
|
|
76
|
|
|
|
|
|
|
|
77
|
|
|
|
|
|
|
# --------------------------------------------------------------------------- |
78
|
|
|
|
|
|
|
|
79
|
|
|
|
|
|
|
=head1 NAME |
80
|
|
|
|
|
|
|
|
81
|
|
|
|
|
|
|
DBIx::Class::Schema::Versioned - DBIx::Class::Schema plugin for Schema upgrades |
82
|
|
|
|
|
|
|
|
83
|
|
|
|
|
|
|
=head1 SYNOPSIS |
84
|
|
|
|
|
|
|
|
85
|
|
|
|
|
|
|
package MyApp::Schema; |
86
|
|
|
|
|
|
|
use base qw/DBIx::Class::Schema/; |
87
|
|
|
|
|
|
|
|
88
|
|
|
|
|
|
|
our $VERSION = 0.001; |
89
|
|
|
|
|
|
|
|
90
|
|
|
|
|
|
|
# load MyApp::Schema::CD, MyApp::Schema::Book, MyApp::Schema::DVD |
91
|
|
|
|
|
|
|
__PACKAGE__->load_classes(qw/CD Book DVD/); |
92
|
|
|
|
|
|
|
|
93
|
|
|
|
|
|
|
__PACKAGE__->load_components(qw/Schema::Versioned/); |
94
|
|
|
|
|
|
|
__PACKAGE__->upgrade_directory('/path/to/upgrades/'); |
95
|
|
|
|
|
|
|
|
96
|
|
|
|
|
|
|
|
97
|
|
|
|
|
|
|
=head1 DESCRIPTION |
98
|
|
|
|
|
|
|
|
99
|
|
|
|
|
|
|
This module provides methods to apply DDL changes to your database using SQL |
100
|
|
|
|
|
|
|
diff files. Normally these diff files would be created using |
101
|
|
|
|
|
|
|
L. |
102
|
|
|
|
|
|
|
|
103
|
|
|
|
|
|
|
A table called I is created and maintained by the |
104
|
|
|
|
|
|
|
module. This is used to determine which version your database is currently at. |
105
|
|
|
|
|
|
|
Similarly the $VERSION in your DBIC schema class is used to determine the |
106
|
|
|
|
|
|
|
current DBIC schema version. |
107
|
|
|
|
|
|
|
|
108
|
|
|
|
|
|
|
The upgrade is initiated manually by calling C on your schema object, |
109
|
|
|
|
|
|
|
this will attempt to upgrade the database from its current version to the current |
110
|
|
|
|
|
|
|
schema version using a diff from your I. If a suitable diff is |
111
|
|
|
|
|
|
|
not found then no upgrade is possible. |
112
|
|
|
|
|
|
|
|
113
|
|
|
|
|
|
|
=head1 SEE ALSO |
114
|
|
|
|
|
|
|
|
115
|
|
|
|
|
|
|
L is a much more powerful alternative to this |
116
|
|
|
|
|
|
|
module. Examples of things it can do that this module cannot do include |
117
|
|
|
|
|
|
|
|
118
|
|
|
|
|
|
|
=over |
119
|
|
|
|
|
|
|
|
120
|
|
|
|
|
|
|
=item * |
121
|
|
|
|
|
|
|
|
122
|
|
|
|
|
|
|
Downgrades in addition to upgrades |
123
|
|
|
|
|
|
|
|
124
|
|
|
|
|
|
|
=item * |
125
|
|
|
|
|
|
|
|
126
|
|
|
|
|
|
|
Multiple sql files per upgrade/downgrade/install |
127
|
|
|
|
|
|
|
|
128
|
|
|
|
|
|
|
=item * |
129
|
|
|
|
|
|
|
|
130
|
|
|
|
|
|
|
Perl scripts allowed for upgrade/downgrade/install |
131
|
|
|
|
|
|
|
|
132
|
|
|
|
|
|
|
=item * |
133
|
|
|
|
|
|
|
|
134
|
|
|
|
|
|
|
Just one set of files needed for upgrade, unlike this module where one might |
135
|
|
|
|
|
|
|
need to generate C |
136
|
|
|
|
|
|
|
|
137
|
|
|
|
|
|
|
=back |
138
|
|
|
|
|
|
|
|
139
|
|
|
|
|
|
|
=head1 GETTING STARTED |
140
|
|
|
|
|
|
|
|
141
|
|
|
|
|
|
|
Firstly you need to setup your schema class as per the L, make sure |
142
|
|
|
|
|
|
|
you have specified an upgrade_directory and an initial $VERSION. |
143
|
|
|
|
|
|
|
|
144
|
|
|
|
|
|
|
Then you'll need two scripts, one to create DDL files and diffs and another to perform |
145
|
|
|
|
|
|
|
upgrades. Your creation script might look like a bit like this: |
146
|
|
|
|
|
|
|
|
147
|
|
|
|
|
|
|
use strict; |
148
|
|
|
|
|
|
|
use Pod::Usage; |
149
|
|
|
|
|
|
|
use Getopt::Long; |
150
|
|
|
|
|
|
|
use MyApp::Schema; |
151
|
|
|
|
|
|
|
|
152
|
|
|
|
|
|
|
my ( $preversion, $help ); |
153
|
|
|
|
|
|
|
GetOptions( |
154
|
|
|
|
|
|
|
'p|preversion:s' => \$preversion, |
155
|
|
|
|
|
|
|
) or die pod2usage; |
156
|
|
|
|
|
|
|
|
157
|
|
|
|
|
|
|
my $schema = MyApp::Schema->connect( |
158
|
|
|
|
|
|
|
$dsn, |
159
|
|
|
|
|
|
|
$user, |
160
|
|
|
|
|
|
|
$password, |
161
|
|
|
|
|
|
|
); |
162
|
|
|
|
|
|
|
my $sql_dir = './sql'; |
163
|
|
|
|
|
|
|
my $version = $schema->schema_version(); |
164
|
|
|
|
|
|
|
$schema->create_ddl_dir( 'MySQL', $version, $sql_dir, $preversion ); |
165
|
|
|
|
|
|
|
|
166
|
|
|
|
|
|
|
Then your upgrade script might look like so: |
167
|
|
|
|
|
|
|
|
168
|
|
|
|
|
|
|
use strict; |
169
|
|
|
|
|
|
|
use MyApp::Schema; |
170
|
|
|
|
|
|
|
|
171
|
|
|
|
|
|
|
my $schema = MyApp::Schema->connect( |
172
|
|
|
|
|
|
|
$dsn, |
173
|
|
|
|
|
|
|
$user, |
174
|
|
|
|
|
|
|
$password, |
175
|
|
|
|
|
|
|
); |
176
|
|
|
|
|
|
|
|
177
|
|
|
|
|
|
|
if (!$schema->get_db_version()) { |
178
|
|
|
|
|
|
|
# schema is unversioned |
179
|
|
|
|
|
|
|
$schema->deploy(); |
180
|
|
|
|
|
|
|
} else { |
181
|
|
|
|
|
|
|
$schema->upgrade(); |
182
|
|
|
|
|
|
|
} |
183
|
|
|
|
|
|
|
|
184
|
|
|
|
|
|
|
The script above assumes that if the database is unversioned then it is empty |
185
|
|
|
|
|
|
|
and we can safely deploy the DDL to it. However things are not always so simple. |
186
|
|
|
|
|
|
|
|
187
|
|
|
|
|
|
|
if you want to initialise a pre-existing database where the DDL is not the same |
188
|
|
|
|
|
|
|
as the DDL for your current schema version then you will need a diff which |
189
|
|
|
|
|
|
|
converts the database's DDL to the current DDL. The best way to do this is |
190
|
|
|
|
|
|
|
to get a dump of the database schema (without data) and save that in your |
191
|
|
|
|
|
|
|
SQL directory as version 0.000 (the filename must be as with |
192
|
|
|
|
|
|
|
L) then create a diff using your create DDL |
193
|
|
|
|
|
|
|
script given above from version 0.000 to the current version. Then hand check |
194
|
|
|
|
|
|
|
and if necessary edit the resulting diff to ensure that it will apply. Once you have |
195
|
|
|
|
|
|
|
done all that you can do this: |
196
|
|
|
|
|
|
|
|
197
|
|
|
|
|
|
|
if (!$schema->get_db_version()) { |
198
|
|
|
|
|
|
|
# schema is unversioned |
199
|
|
|
|
|
|
|
$schema->install("0.000"); |
200
|
|
|
|
|
|
|
} |
201
|
|
|
|
|
|
|
|
202
|
|
|
|
|
|
|
# this will now apply the 0.000 to current version diff |
203
|
|
|
|
|
|
|
$schema->upgrade(); |
204
|
|
|
|
|
|
|
|
205
|
|
|
|
|
|
|
In the case of an unversioned database the above code will create the |
206
|
|
|
|
|
|
|
dbix_class_schema_versions table and write version 0.000 to it, then |
207
|
|
|
|
|
|
|
upgrade will then apply the diff we talked about creating in the previous paragraph |
208
|
|
|
|
|
|
|
and then you're good to go. |
209
|
|
|
|
|
|
|
|
210
|
|
|
|
|
|
|
=cut |
211
|
|
|
|
|
|
|
|
212
|
|
|
|
|
|
|
package DBIx::Class::Schema::Versioned; |
213
|
|
|
|
|
|
|
|
214
|
3
|
|
|
3
|
|
17
|
use strict; |
|
3
|
|
|
|
|
6
|
|
|
3
|
|
|
|
|
97
|
|
215
|
3
|
|
|
3
|
|
15
|
use warnings; |
|
3
|
|
|
|
|
7
|
|
|
3
|
|
|
|
|
76
|
|
216
|
3
|
|
|
3
|
|
14
|
use base 'DBIx::Class::Schema'; |
|
3
|
|
|
|
|
6
|
|
|
3
|
|
|
|
|
258
|
|
217
|
|
|
|
|
|
|
|
218
|
3
|
|
|
3
|
|
23
|
use DBIx::Class::Carp; |
|
3
|
|
|
|
|
13
|
|
|
3
|
|
|
|
|
32
|
|
219
|
3
|
|
|
3
|
|
19
|
use DBIx::Class::_Util qw( dbic_internal_try UNRESOLVABLE_CONDITION ); |
|
3
|
|
|
|
|
6
|
|
|
3
|
|
|
|
|
181
|
|
220
|
3
|
|
|
3
|
|
17
|
use Scalar::Util 'weaken'; |
|
3
|
|
|
|
|
8
|
|
|
3
|
|
|
|
|
115
|
|
221
|
3
|
|
|
3
|
|
15
|
use namespace::clean; |
|
3
|
|
|
|
|
6
|
|
|
3
|
|
|
|
|
21
|
|
222
|
|
|
|
|
|
|
|
223
|
|
|
|
|
|
|
__PACKAGE__->mk_group_accessors( inherited => qw( |
224
|
|
|
|
|
|
|
_filedata |
225
|
|
|
|
|
|
|
upgrade_directory |
226
|
|
|
|
|
|
|
backup_directory |
227
|
|
|
|
|
|
|
do_backup |
228
|
|
|
|
|
|
|
do_diff_on_init |
229
|
|
|
|
|
|
|
) ); |
230
|
|
|
|
|
|
|
|
231
|
|
|
|
|
|
|
|
232
|
|
|
|
|
|
|
=head1 METHODS |
233
|
|
|
|
|
|
|
|
234
|
|
|
|
|
|
|
=head2 upgrade_directory |
235
|
|
|
|
|
|
|
|
236
|
|
|
|
|
|
|
Use this to set the directory your upgrade files are stored in. |
237
|
|
|
|
|
|
|
|
238
|
|
|
|
|
|
|
=head2 backup_directory |
239
|
|
|
|
|
|
|
|
240
|
|
|
|
|
|
|
Use this to set the directory you want your backups stored in (note that backups |
241
|
|
|
|
|
|
|
are disabled by default). |
242
|
|
|
|
|
|
|
|
243
|
|
|
|
|
|
|
=cut |
244
|
|
|
|
|
|
|
|
245
|
|
|
|
|
|
|
=head2 install |
246
|
|
|
|
|
|
|
|
247
|
|
|
|
|
|
|
=over 4 |
248
|
|
|
|
|
|
|
|
249
|
|
|
|
|
|
|
=item Arguments: $db_version |
250
|
|
|
|
|
|
|
|
251
|
|
|
|
|
|
|
=back |
252
|
|
|
|
|
|
|
|
253
|
|
|
|
|
|
|
Call this to initialise a previously unversioned database. The table 'dbix_class_schema_versions' will be created which will be used to store the database version. |
254
|
|
|
|
|
|
|
|
255
|
|
|
|
|
|
|
Takes one argument which should be the version that the database is currently at. Defaults to the return value of L. |
256
|
|
|
|
|
|
|
|
257
|
|
|
|
|
|
|
See L for more details. |
258
|
|
|
|
|
|
|
|
259
|
|
|
|
|
|
|
=cut |
260
|
|
|
|
|
|
|
|
261
|
|
|
|
|
|
|
sub install |
262
|
|
|
|
|
|
|
{ |
263
|
0
|
|
|
0
|
1
|
|
my ($self, $new_version) = @_; |
264
|
|
|
|
|
|
|
|
265
|
|
|
|
|
|
|
# must be called on a fresh database |
266
|
0
|
0
|
|
|
|
|
if ($self->get_db_version()) { |
267
|
0
|
|
|
|
|
|
$self->throw_exception("A versioned schema has already been deployed, try upgrade instead.\n"); |
268
|
|
|
|
|
|
|
} |
269
|
|
|
|
|
|
|
|
270
|
|
|
|
|
|
|
# default to current version if none passed |
271
|
0
|
|
0
|
|
|
|
$new_version ||= $self->schema_version(); |
272
|
|
|
|
|
|
|
|
273
|
0
|
0
|
|
|
|
|
if ($new_version) { |
274
|
|
|
|
|
|
|
# create versions table and version row |
275
|
0
|
|
|
|
|
|
$self->{vschema}->deploy; |
276
|
0
|
|
|
|
|
|
$self->_set_db_version({ version => $new_version }); |
277
|
|
|
|
|
|
|
} |
278
|
|
|
|
|
|
|
} |
279
|
|
|
|
|
|
|
|
280
|
|
|
|
|
|
|
=head2 deploy |
281
|
|
|
|
|
|
|
|
282
|
|
|
|
|
|
|
Same as L but also calls C. |
283
|
|
|
|
|
|
|
|
284
|
|
|
|
|
|
|
=cut |
285
|
|
|
|
|
|
|
|
286
|
|
|
|
|
|
|
sub deploy { |
287
|
0
|
|
|
0
|
1
|
|
my $self = shift; |
288
|
0
|
|
|
|
|
|
$self->next::method(@_); |
289
|
0
|
|
|
|
|
|
$self->install(); |
290
|
|
|
|
|
|
|
} |
291
|
|
|
|
|
|
|
|
292
|
|
|
|
|
|
|
=head2 create_upgrade_path |
293
|
|
|
|
|
|
|
|
294
|
|
|
|
|
|
|
=over 4 |
295
|
|
|
|
|
|
|
|
296
|
|
|
|
|
|
|
=item Arguments: { upgrade_file => $file } |
297
|
|
|
|
|
|
|
|
298
|
|
|
|
|
|
|
=back |
299
|
|
|
|
|
|
|
|
300
|
|
|
|
|
|
|
Virtual method that should be overridden to create an upgrade file. |
301
|
|
|
|
|
|
|
This is useful in the case of upgrading across multiple versions |
302
|
|
|
|
|
|
|
to concatenate several files to create one upgrade file. |
303
|
|
|
|
|
|
|
|
304
|
|
|
|
|
|
|
You'll probably want the db_version retrieved via $self->get_db_version |
305
|
|
|
|
|
|
|
and the schema_version which is retrieved via $self->schema_version |
306
|
|
|
|
|
|
|
|
307
|
|
|
|
|
|
|
=cut |
308
|
|
|
|
|
|
|
|
309
|
|
|
|
0
|
1
|
|
sub create_upgrade_path { |
310
|
|
|
|
|
|
|
## override this method |
311
|
|
|
|
|
|
|
} |
312
|
|
|
|
|
|
|
|
313
|
|
|
|
|
|
|
=head2 ordered_schema_versions |
314
|
|
|
|
|
|
|
|
315
|
|
|
|
|
|
|
=over 4 |
316
|
|
|
|
|
|
|
|
317
|
|
|
|
|
|
|
=item Return Value: a list of version numbers, ordered from lowest to highest |
318
|
|
|
|
|
|
|
|
319
|
|
|
|
|
|
|
=back |
320
|
|
|
|
|
|
|
|
321
|
|
|
|
|
|
|
Virtual method that should be overridden to return an ordered list |
322
|
|
|
|
|
|
|
of schema versions. This is then used to produce a set of steps to |
323
|
|
|
|
|
|
|
upgrade through to achieve the required schema version. |
324
|
|
|
|
|
|
|
|
325
|
|
|
|
|
|
|
You may want the db_version retrieved via $self->get_db_version |
326
|
|
|
|
|
|
|
and the schema_version which is retrieved via $self->schema_version |
327
|
|
|
|
|
|
|
|
328
|
|
|
|
|
|
|
=cut |
329
|
|
|
|
|
|
|
|
330
|
|
|
|
0
|
1
|
|
sub ordered_schema_versions { |
331
|
|
|
|
|
|
|
## override this method |
332
|
|
|
|
|
|
|
} |
333
|
|
|
|
|
|
|
|
334
|
|
|
|
|
|
|
=head2 upgrade |
335
|
|
|
|
|
|
|
|
336
|
|
|
|
|
|
|
Call this to attempt to upgrade your database from the version it |
337
|
|
|
|
|
|
|
is at to the version this DBIC schema is at. If they are the same |
338
|
|
|
|
|
|
|
it does nothing. |
339
|
|
|
|
|
|
|
|
340
|
|
|
|
|
|
|
It will call L to retrieve an ordered |
341
|
|
|
|
|
|
|
list of schema versions (if ordered_schema_versions returns nothing |
342
|
|
|
|
|
|
|
then it is assumed you can do the upgrade as a single step). It |
343
|
|
|
|
|
|
|
then iterates through the list of versions between the current db |
344
|
|
|
|
|
|
|
version and the schema version applying one update at a time until |
345
|
|
|
|
|
|
|
all relevant updates are applied. |
346
|
|
|
|
|
|
|
|
347
|
|
|
|
|
|
|
The individual update steps are performed by using |
348
|
|
|
|
|
|
|
L, which will apply the update and also |
349
|
|
|
|
|
|
|
update the dbix_class_schema_versions table. |
350
|
|
|
|
|
|
|
|
351
|
|
|
|
|
|
|
=cut |
352
|
|
|
|
|
|
|
|
353
|
|
|
|
|
|
|
sub upgrade { |
354
|
0
|
|
|
0
|
1
|
|
my ($self) = @_; |
355
|
0
|
|
|
|
|
|
my $db_version = $self->get_db_version(); |
356
|
|
|
|
|
|
|
|
357
|
|
|
|
|
|
|
# db unversioned |
358
|
0
|
0
|
|
|
|
|
unless ($db_version) { |
359
|
0
|
|
|
|
|
|
carp 'Upgrade not possible as database is unversioned. Please call install first.'; |
360
|
0
|
|
|
|
|
|
return; |
361
|
|
|
|
|
|
|
} |
362
|
|
|
|
|
|
|
|
363
|
|
|
|
|
|
|
# db and schema at same version. do nothing |
364
|
0
|
0
|
|
|
|
|
if ( $db_version eq $self->schema_version ) { |
365
|
0
|
|
|
|
|
|
carp 'Upgrade not necessary'; |
366
|
0
|
|
|
|
|
|
return; |
367
|
|
|
|
|
|
|
} |
368
|
|
|
|
|
|
|
|
369
|
0
|
|
|
|
|
|
my @version_list = $self->ordered_schema_versions; |
370
|
|
|
|
|
|
|
|
371
|
|
|
|
|
|
|
# if nothing returned then we preload with min/max |
372
|
0
|
0
|
|
|
|
|
@version_list = ( $db_version, $self->schema_version ) |
373
|
|
|
|
|
|
|
unless ( scalar(@version_list) ); |
374
|
|
|
|
|
|
|
|
375
|
|
|
|
|
|
|
# catch the case of someone returning an arrayref |
376
|
0
|
0
|
|
|
|
|
@version_list = @{ $version_list[0] } |
|
0
|
|
|
|
|
|
|
377
|
|
|
|
|
|
|
if ( ref( $version_list[0] ) eq 'ARRAY' ); |
378
|
|
|
|
|
|
|
|
379
|
|
|
|
|
|
|
# remove all versions in list above the required version |
380
|
0
|
|
0
|
|
|
|
while ( scalar(@version_list) |
381
|
|
|
|
|
|
|
&& ( $version_list[-1] ne $self->schema_version ) ) |
382
|
|
|
|
|
|
|
{ |
383
|
0
|
|
|
|
|
|
pop @version_list; |
384
|
|
|
|
|
|
|
} |
385
|
|
|
|
|
|
|
|
386
|
|
|
|
|
|
|
# remove all versions in list below the current version |
387
|
0
|
|
0
|
|
|
|
while ( scalar(@version_list) && ( $version_list[0] ne $db_version ) ) { |
388
|
0
|
|
|
|
|
|
shift @version_list; |
389
|
|
|
|
|
|
|
} |
390
|
|
|
|
|
|
|
|
391
|
|
|
|
|
|
|
# check we have an appropriate list of versions |
392
|
0
|
0
|
|
|
|
|
if ( scalar(@version_list) < 2 ) { |
393
|
0
|
|
|
|
|
|
die; |
394
|
|
|
|
|
|
|
} |
395
|
|
|
|
|
|
|
|
396
|
|
|
|
|
|
|
# do sets of upgrade |
397
|
0
|
|
|
|
|
|
while ( scalar(@version_list) >= 2 ) { |
398
|
0
|
|
|
|
|
|
$self->upgrade_single_step( $version_list[0], $version_list[1] ); |
399
|
0
|
|
|
|
|
|
shift @version_list; |
400
|
|
|
|
|
|
|
} |
401
|
|
|
|
|
|
|
} |
402
|
|
|
|
|
|
|
|
403
|
|
|
|
|
|
|
=head2 upgrade_single_step |
404
|
|
|
|
|
|
|
|
405
|
|
|
|
|
|
|
=over 4 |
406
|
|
|
|
|
|
|
|
407
|
|
|
|
|
|
|
=item Arguments: db_version - the version currently within the db |
408
|
|
|
|
|
|
|
|
409
|
|
|
|
|
|
|
=item Arguments: target_version - the version to upgrade to |
410
|
|
|
|
|
|
|
|
411
|
|
|
|
|
|
|
=back |
412
|
|
|
|
|
|
|
|
413
|
|
|
|
|
|
|
Call this to attempt to upgrade your database from the |
414
|
|
|
|
|
|
|
I to the I. If they are the same it |
415
|
|
|
|
|
|
|
does nothing. |
416
|
|
|
|
|
|
|
|
417
|
|
|
|
|
|
|
It requires an SQL diff file to exist in your I, |
418
|
|
|
|
|
|
|
normally you will have created this using L. |
419
|
|
|
|
|
|
|
|
420
|
|
|
|
|
|
|
If successful the dbix_class_schema_versions table is updated with |
421
|
|
|
|
|
|
|
the I. |
422
|
|
|
|
|
|
|
|
423
|
|
|
|
|
|
|
This method may be called repeatedly by the upgrade method to |
424
|
|
|
|
|
|
|
upgrade through a series of updates. |
425
|
|
|
|
|
|
|
|
426
|
|
|
|
|
|
|
=cut |
427
|
|
|
|
|
|
|
|
428
|
|
|
|
|
|
|
sub upgrade_single_step |
429
|
|
|
|
|
|
|
{ |
430
|
0
|
|
|
0
|
1
|
|
my ($self, |
431
|
|
|
|
|
|
|
$db_version, |
432
|
|
|
|
|
|
|
$target_version) = @_; |
433
|
|
|
|
|
|
|
|
434
|
|
|
|
|
|
|
# db and schema at same version. do nothing |
435
|
0
|
0
|
|
|
|
|
if ($db_version eq $target_version) { |
436
|
0
|
|
|
|
|
|
carp 'Upgrade not necessary'; |
437
|
0
|
|
|
|
|
|
return; |
438
|
|
|
|
|
|
|
} |
439
|
|
|
|
|
|
|
|
440
|
|
|
|
|
|
|
# strangely the first time this is called can |
441
|
|
|
|
|
|
|
# differ to subsequent times. so we call it |
442
|
|
|
|
|
|
|
# here to be sure. |
443
|
|
|
|
|
|
|
# XXX - just fix it |
444
|
0
|
|
|
|
|
|
$self->storage->sqlt_type; |
445
|
|
|
|
|
|
|
|
446
|
0
|
|
|
|
|
|
my $upgrade_file = $self->ddl_filename( |
447
|
|
|
|
|
|
|
$self->storage->sqlt_type, |
448
|
|
|
|
|
|
|
$target_version, |
449
|
|
|
|
|
|
|
$self->upgrade_directory, |
450
|
|
|
|
|
|
|
$db_version, |
451
|
|
|
|
|
|
|
); |
452
|
|
|
|
|
|
|
|
453
|
0
|
|
|
|
|
|
$self->create_upgrade_path({ upgrade_file => $upgrade_file }); |
454
|
|
|
|
|
|
|
|
455
|
0
|
0
|
|
|
|
|
unless (-f $upgrade_file) { |
456
|
0
|
|
|
|
|
|
carp "Upgrade not possible, no upgrade file found ($upgrade_file), please create one"; |
457
|
0
|
|
|
|
|
|
return; |
458
|
|
|
|
|
|
|
} |
459
|
|
|
|
|
|
|
|
460
|
0
|
|
|
|
|
|
carp "DB version ($db_version) is lower than the schema version (".$self->schema_version."). Attempting upgrade.\n"; |
461
|
|
|
|
|
|
|
|
462
|
|
|
|
|
|
|
# backup if necessary then apply upgrade |
463
|
0
|
|
|
|
|
|
$self->_filedata($self->_read_sql_file($upgrade_file)); |
464
|
0
|
0
|
|
|
|
|
$self->backup() if($self->do_backup); |
465
|
0
|
|
|
0
|
|
|
$self->txn_do(sub { $self->do_upgrade() }); |
|
0
|
|
|
|
|
|
|
466
|
|
|
|
|
|
|
|
467
|
|
|
|
|
|
|
# set row in dbix_class_schema_versions table |
468
|
0
|
|
|
|
|
|
$self->_set_db_version({version => $target_version}); |
469
|
|
|
|
|
|
|
} |
470
|
|
|
|
|
|
|
|
471
|
|
|
|
|
|
|
=head2 do_upgrade |
472
|
|
|
|
|
|
|
|
473
|
|
|
|
|
|
|
This is an overwritable method used to run your upgrade. The freeform method |
474
|
|
|
|
|
|
|
allows you to run your upgrade any way you please, you can call C |
475
|
|
|
|
|
|
|
any number of times to run the actual SQL commands, and in between you can |
476
|
|
|
|
|
|
|
sandwich your data upgrading. For example, first run all the B |
477
|
|
|
|
|
|
|
commands, then migrate your data from old to new tables/formats, then |
478
|
|
|
|
|
|
|
issue the DROP commands when you are finished. Will run the whole file as it is by default. |
479
|
|
|
|
|
|
|
|
480
|
|
|
|
|
|
|
=cut |
481
|
|
|
|
|
|
|
|
482
|
|
|
|
|
|
|
sub do_upgrade |
483
|
|
|
|
|
|
|
{ |
484
|
0
|
|
|
0
|
1
|
|
my ($self) = @_; |
485
|
|
|
|
|
|
|
|
486
|
|
|
|
|
|
|
# just run all the commands (including inserts) in order |
487
|
0
|
|
|
|
|
|
$self->run_upgrade(qr/.*?/); |
488
|
|
|
|
|
|
|
} |
489
|
|
|
|
|
|
|
|
490
|
|
|
|
|
|
|
=head2 run_upgrade |
491
|
|
|
|
|
|
|
|
492
|
|
|
|
|
|
|
$self->run_upgrade(qr/create/i); |
493
|
|
|
|
|
|
|
|
494
|
|
|
|
|
|
|
Runs a set of SQL statements matching a passed in regular expression. The |
495
|
|
|
|
|
|
|
idea is that this method can be called any number of times from your |
496
|
|
|
|
|
|
|
C method, running whichever commands you specify via the |
497
|
|
|
|
|
|
|
regex in the parameter. Probably won't work unless called from the overridable |
498
|
|
|
|
|
|
|
do_upgrade method. |
499
|
|
|
|
|
|
|
|
500
|
|
|
|
|
|
|
=cut |
501
|
|
|
|
|
|
|
|
502
|
|
|
|
|
|
|
sub run_upgrade |
503
|
|
|
|
|
|
|
{ |
504
|
0
|
|
|
0
|
1
|
|
my ($self, $stm) = @_; |
505
|
|
|
|
|
|
|
|
506
|
0
|
0
|
|
|
|
|
return unless ($self->_filedata); |
507
|
0
|
|
|
|
|
|
my @statements = grep { $_ =~ $stm } @{$self->_filedata}; |
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
508
|
0
|
|
|
|
|
|
$self->_filedata([ grep { $_ !~ /$stm/i } @{$self->_filedata} ]); |
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
509
|
|
|
|
|
|
|
|
510
|
0
|
|
|
|
|
|
for (@statements) |
511
|
|
|
|
|
|
|
{ |
512
|
0
|
0
|
|
|
|
|
$self->storage->debugobj->query_start($_) if $self->storage->debug; |
513
|
0
|
|
|
|
|
|
$self->apply_statement($_); |
514
|
0
|
0
|
|
|
|
|
$self->storage->debugobj->query_end($_) if $self->storage->debug; |
515
|
|
|
|
|
|
|
} |
516
|
|
|
|
|
|
|
|
517
|
0
|
|
|
|
|
|
return 1; |
518
|
|
|
|
|
|
|
} |
519
|
|
|
|
|
|
|
|
520
|
|
|
|
|
|
|
=head2 apply_statement |
521
|
|
|
|
|
|
|
|
522
|
|
|
|
|
|
|
Takes an SQL statement and runs it. Override this if you want to handle errors |
523
|
|
|
|
|
|
|
differently. |
524
|
|
|
|
|
|
|
|
525
|
|
|
|
|
|
|
=cut |
526
|
|
|
|
|
|
|
|
527
|
|
|
|
|
|
|
sub apply_statement { |
528
|
0
|
|
|
0
|
1
|
|
my ($self, $statement) = @_; |
529
|
|
|
|
|
|
|
|
530
|
0
|
0
|
|
|
|
|
$self->storage->dbh->do($_) or carp "SQL was: $_"; |
531
|
|
|
|
|
|
|
} |
532
|
|
|
|
|
|
|
|
533
|
|
|
|
|
|
|
=head2 get_db_version |
534
|
|
|
|
|
|
|
|
535
|
|
|
|
|
|
|
Returns the version that your database is currently at. This is determined by the values in the |
536
|
|
|
|
|
|
|
dbix_class_schema_versions table that C and C write to. |
537
|
|
|
|
|
|
|
|
538
|
|
|
|
|
|
|
=cut |
539
|
|
|
|
|
|
|
|
540
|
|
|
|
|
|
|
sub get_db_version |
541
|
|
|
|
|
|
|
{ |
542
|
0
|
|
|
0
|
1
|
|
my ($self, $rs) = @_; |
543
|
|
|
|
|
|
|
|
544
|
0
|
|
|
|
|
|
my $vtable = $self->{vschema}->resultset('Table'); |
545
|
|
|
|
|
|
|
my $version = dbic_internal_try { |
546
|
0
|
|
|
0
|
|
|
$vtable->search_rs({}, { order_by => { -desc => 'installed' }, rows => 1 } ) |
547
|
|
|
|
|
|
|
->get_column ('version') |
548
|
|
|
|
|
|
|
->next; |
549
|
0
|
|
|
|
|
|
}; |
550
|
0
|
|
0
|
|
|
|
return $version || 0; |
551
|
|
|
|
|
|
|
} |
552
|
|
|
|
|
|
|
|
553
|
|
|
|
|
|
|
=head2 schema_version |
554
|
|
|
|
|
|
|
|
555
|
|
|
|
|
|
|
Returns the current schema class' $VERSION |
556
|
|
|
|
|
|
|
|
557
|
|
|
|
|
|
|
=cut |
558
|
|
|
|
|
|
|
|
559
|
|
|
|
|
|
|
=head2 backup |
560
|
|
|
|
|
|
|
|
561
|
|
|
|
|
|
|
This is an overwritable method which is called just before the upgrade, to |
562
|
|
|
|
|
|
|
allow you to make a backup of the database. Per default this method attempts |
563
|
|
|
|
|
|
|
to call C<< $self->storage->backup >>, to run the standard backup on each |
564
|
|
|
|
|
|
|
database type. |
565
|
|
|
|
|
|
|
|
566
|
|
|
|
|
|
|
This method should return the name of the backup file, if appropriate.. |
567
|
|
|
|
|
|
|
|
568
|
|
|
|
|
|
|
This method is disabled by default. Set $schema->do_backup(1) to enable it. |
569
|
|
|
|
|
|
|
|
570
|
|
|
|
|
|
|
=cut |
571
|
|
|
|
|
|
|
|
572
|
|
|
|
|
|
|
sub backup |
573
|
|
|
|
|
|
|
{ |
574
|
0
|
|
|
0
|
1
|
|
my ($self) = @_; |
575
|
|
|
|
|
|
|
## Make each ::DBI::Foo do this |
576
|
0
|
|
|
|
|
|
$self->storage->backup($self->backup_directory()); |
577
|
|
|
|
|
|
|
} |
578
|
|
|
|
|
|
|
|
579
|
|
|
|
|
|
|
=head2 connection |
580
|
|
|
|
|
|
|
|
581
|
|
|
|
|
|
|
Overloaded method. This checks the DBIC schema version against the DB version and |
582
|
|
|
|
|
|
|
warns if they are not the same or if the DB is unversioned. It also provides |
583
|
|
|
|
|
|
|
compatibility between the old versions table (SchemaVersions) and the new one |
584
|
|
|
|
|
|
|
(dbix_class_schema_versions). |
585
|
|
|
|
|
|
|
|
586
|
|
|
|
|
|
|
To avoid the checks on connect, set the environment var DBIC_NO_VERSION_CHECK or alternatively you can set the ignore_version attr in the forth argument like so: |
587
|
|
|
|
|
|
|
|
588
|
|
|
|
|
|
|
my $schema = MyApp::Schema->connect( |
589
|
|
|
|
|
|
|
$dsn, |
590
|
|
|
|
|
|
|
$user, |
591
|
|
|
|
|
|
|
$password, |
592
|
|
|
|
|
|
|
{ ignore_version => 1 }, |
593
|
|
|
|
|
|
|
); |
594
|
|
|
|
|
|
|
|
595
|
|
|
|
|
|
|
=cut |
596
|
|
|
|
|
|
|
|
597
|
|
|
|
|
|
|
sub connection { |
598
|
0
|
|
|
0
|
1
|
|
my $self = shift; |
599
|
0
|
|
|
|
|
|
$self->next::method(@_); |
600
|
0
|
|
|
|
|
|
$self->_on_connect(); |
601
|
0
|
|
|
|
|
|
return $self; |
602
|
|
|
|
|
|
|
} |
603
|
|
|
|
|
|
|
|
604
|
|
|
|
|
|
|
sub _on_connect |
605
|
|
|
|
|
|
|
{ |
606
|
0
|
|
|
0
|
|
|
my ($self) = @_; |
607
|
|
|
|
|
|
|
|
608
|
0
|
|
|
|
|
|
weaken (my $w_storage = $self->storage ); |
609
|
|
|
|
|
|
|
|
610
|
|
|
|
|
|
|
$self->{vschema} = DBIx::Class::Version->clone->connection( |
611
|
0
|
|
|
0
|
|
|
sub { $w_storage->dbh }, |
612
|
|
|
|
|
|
|
|
613
|
|
|
|
|
|
|
# proxy some flags from the main storage |
614
|
0
|
|
|
|
|
|
{ map { $_ => $w_storage->$_ } qw( unsafe ) }, |
|
0
|
|
|
|
|
|
|
615
|
|
|
|
|
|
|
); |
616
|
0
|
|
0
|
|
|
|
my $conn_attrs = $w_storage->_dbic_connect_attributes || {}; |
617
|
|
|
|
|
|
|
|
618
|
0
|
|
|
|
|
|
my $vtable = $self->{vschema}->resultset('Table'); |
619
|
|
|
|
|
|
|
|
620
|
|
|
|
|
|
|
# useful when connecting from scripts etc |
621
|
0
|
0
|
0
|
|
|
|
return if ($conn_attrs->{ignore_version} || ($ENV{DBIC_NO_VERSION_CHECK} && !exists $conn_attrs->{ignore_version})); |
|
|
|
0
|
|
|
|
|
622
|
|
|
|
|
|
|
|
623
|
|
|
|
|
|
|
# check for legacy versions table and move to new if exists |
624
|
0
|
0
|
|
|
|
|
unless ($self->_source_exists($vtable)) { |
625
|
0
|
|
|
0
|
|
|
my $vtable_compat = DBIx::Class::VersionCompat->clone->connection(sub { $w_storage->dbh })->resultset('TableCompat'); |
|
0
|
|
|
|
|
|
|
626
|
0
|
0
|
|
|
|
|
if ($self->_source_exists($vtable_compat)) { |
627
|
0
|
|
|
|
|
|
$self->{vschema}->deploy; |
628
|
0
|
|
|
|
|
|
map { $vtable->new_result({ installed => $_->Installed, version => $_->Version })->insert } $vtable_compat->all; |
|
0
|
|
|
|
|
|
|
629
|
0
|
|
|
|
|
|
$w_storage->_get_dbh->do("DROP TABLE " . $vtable_compat->result_source->from); |
630
|
|
|
|
|
|
|
} |
631
|
|
|
|
|
|
|
} |
632
|
|
|
|
|
|
|
|
633
|
0
|
|
|
|
|
|
my $pversion = $self->get_db_version(); |
634
|
|
|
|
|
|
|
|
635
|
0
|
0
|
|
|
|
|
if($pversion eq $self->schema_version) |
636
|
|
|
|
|
|
|
{ |
637
|
|
|
|
|
|
|
#carp "This version is already installed"; |
638
|
0
|
|
|
|
|
|
return 1; |
639
|
|
|
|
|
|
|
} |
640
|
|
|
|
|
|
|
|
641
|
0
|
0
|
|
|
|
|
if(!$pversion) |
642
|
|
|
|
|
|
|
{ |
643
|
0
|
|
|
|
|
|
carp "Your DB is currently unversioned. Please call upgrade on your schema to sync the DB."; |
644
|
0
|
|
|
|
|
|
return 1; |
645
|
|
|
|
|
|
|
} |
646
|
|
|
|
|
|
|
|
647
|
0
|
|
|
|
|
|
carp "Versions out of sync. This is " . $self->schema_version . |
648
|
|
|
|
|
|
|
", your database contains version $pversion, please call upgrade on your Schema."; |
649
|
|
|
|
|
|
|
} |
650
|
|
|
|
|
|
|
|
651
|
|
|
|
|
|
|
# is this just a waste of time? if not then merge with DBI.pm |
652
|
|
|
|
|
|
|
sub _create_db_to_schema_diff { |
653
|
0
|
|
|
0
|
|
|
my $self = shift; |
654
|
|
|
|
|
|
|
|
655
|
0
|
|
|
|
|
|
my %driver_to_db_map = ( |
656
|
|
|
|
|
|
|
'mysql' => 'MySQL' |
657
|
|
|
|
|
|
|
); |
658
|
|
|
|
|
|
|
|
659
|
0
|
|
|
|
|
|
my $db = $driver_to_db_map{$self->storage->dbh->{Driver}->{Name}}; |
660
|
0
|
0
|
|
|
|
|
unless ($db) { |
661
|
0
|
|
|
|
|
|
print "Sorry, this is an unsupported DB\n"; |
662
|
0
|
|
|
|
|
|
return; |
663
|
|
|
|
|
|
|
} |
664
|
|
|
|
|
|
|
|
665
|
0
|
|
|
|
|
|
require DBIx::Class::Optional::Dependencies; |
666
|
0
|
0
|
|
|
|
|
if ( my $missing = DBIx::Class::Optional::Dependencies->req_missing_for('deploy') ) { |
667
|
0
|
|
|
|
|
|
$self->throw_exception("Unable to proceed without $missing"); |
668
|
|
|
|
|
|
|
} |
669
|
|
|
|
|
|
|
|
670
|
0
|
|
|
|
|
|
my $db_tr = SQL::Translator->new({ |
671
|
|
|
|
|
|
|
add_drop_table => 1, |
672
|
|
|
|
|
|
|
parser => 'DBI', |
673
|
|
|
|
|
|
|
parser_args => { dbh => $self->storage->dbh } |
674
|
|
|
|
|
|
|
}); |
675
|
|
|
|
|
|
|
|
676
|
0
|
|
|
|
|
|
$db_tr->producer($db); |
677
|
0
|
|
|
|
|
|
my $dbic_tr = SQL::Translator->new; |
678
|
0
|
|
|
|
|
|
$dbic_tr->parser('SQL::Translator::Parser::DBIx::Class'); |
679
|
0
|
|
|
|
|
|
$dbic_tr->data($self); |
680
|
0
|
|
|
|
|
|
$dbic_tr->producer($db); |
681
|
|
|
|
|
|
|
|
682
|
0
|
|
|
|
|
|
$db_tr->schema->name('db_schema'); |
683
|
0
|
|
|
|
|
|
$dbic_tr->schema->name('dbic_schema'); |
684
|
|
|
|
|
|
|
|
685
|
|
|
|
|
|
|
# is this really necessary? |
686
|
0
|
|
|
|
|
|
foreach my $tr ($db_tr, $dbic_tr) { |
687
|
0
|
|
|
|
|
|
my $data = $tr->data; |
688
|
0
|
|
|
|
|
|
$tr->parser->($tr, $$data); |
689
|
|
|
|
|
|
|
} |
690
|
|
|
|
|
|
|
|
691
|
0
|
|
|
|
|
|
my $diff = SQL::Translator::Diff::schema_diff($db_tr->schema, $db, |
692
|
|
|
|
|
|
|
$dbic_tr->schema, $db, |
693
|
|
|
|
|
|
|
{ ignore_constraint_names => 1, ignore_index_names => 1, caseopt => 1 }); |
694
|
|
|
|
|
|
|
|
695
|
0
|
|
|
|
|
|
my $filename = $self->ddl_filename( |
696
|
|
|
|
|
|
|
$db, |
697
|
|
|
|
|
|
|
$self->schema_version, |
698
|
|
|
|
|
|
|
$self->upgrade_directory, |
699
|
|
|
|
|
|
|
'PRE', |
700
|
|
|
|
|
|
|
); |
701
|
0
|
|
|
|
|
|
my $file; |
702
|
0
|
0
|
|
|
|
|
if(!open($file, ">$filename")) |
703
|
|
|
|
|
|
|
{ |
704
|
0
|
|
|
|
|
|
$self->throw_exception("Can't open $filename for writing ($!)"); |
705
|
0
|
|
|
|
|
|
next; |
706
|
|
|
|
|
|
|
} |
707
|
0
|
|
|
|
|
|
print $file $diff; |
708
|
0
|
|
|
|
|
|
close($file); |
709
|
|
|
|
|
|
|
|
710
|
0
|
|
|
|
|
|
carp "WARNING: There may be differences between your DB and your DBIC schema. Please review and if necessary run the SQL in $filename to sync your DB."; |
711
|
|
|
|
|
|
|
} |
712
|
|
|
|
|
|
|
|
713
|
|
|
|
|
|
|
|
714
|
|
|
|
|
|
|
sub _set_db_version { |
715
|
0
|
|
|
0
|
|
|
my $self = shift; |
716
|
0
|
|
|
|
|
|
my ($params) = @_; |
717
|
0
|
|
0
|
|
|
|
$params ||= {}; |
718
|
|
|
|
|
|
|
|
719
|
0
|
0
|
|
|
|
|
my $version = $params->{version} ? $params->{version} : $self->schema_version; |
720
|
0
|
|
|
|
|
|
my $vtable = $self->{vschema}->resultset('Table'); |
721
|
|
|
|
|
|
|
|
722
|
|
|
|
|
|
|
############################################################################## |
723
|
|
|
|
|
|
|
# !!! NOTE !!! |
724
|
|
|
|
|
|
|
############################################################################## |
725
|
|
|
|
|
|
|
# |
726
|
|
|
|
|
|
|
# The travesty below replaces the old nice timestamp format of %Y-%m-%d %H:%M:%S |
727
|
|
|
|
|
|
|
# This is necessary since there are legitimate cases when upgrades can happen |
728
|
|
|
|
|
|
|
# back to back within the same second. This breaks things since we relay on the |
729
|
|
|
|
|
|
|
# ability to sort by the 'installed' value. The logical choice of an autoinc |
730
|
|
|
|
|
|
|
# is not possible, as it will break multiple legacy installations. Also it is |
731
|
|
|
|
|
|
|
# not possible to format the string sanely, as the column is a varchar(20). |
732
|
|
|
|
|
|
|
# The 'v' character is added to the front of the string, so that any version |
733
|
|
|
|
|
|
|
# formatted by this new function will sort _after_ any existing 200... strings. |
734
|
0
|
|
|
|
|
|
require Time::HiRes; |
735
|
0
|
|
|
|
|
|
my @tm = Time::HiRes::gettimeofday(); |
736
|
0
|
|
|
|
|
|
my @dt = gmtime ($tm[0]); |
737
|
0
|
|
|
|
|
|
my $o = $vtable->new_result({ |
738
|
|
|
|
|
|
|
version => $version, |
739
|
|
|
|
|
|
|
installed => sprintf("v%04d%02d%02d_%02d%02d%02d.%03.0f", |
740
|
|
|
|
|
|
|
$dt[5] + 1900, |
741
|
|
|
|
|
|
|
$dt[4] + 1, |
742
|
|
|
|
|
|
|
$dt[3], |
743
|
|
|
|
|
|
|
$dt[2], |
744
|
|
|
|
|
|
|
$dt[1], |
745
|
|
|
|
|
|
|
$dt[0], |
746
|
|
|
|
|
|
|
int($tm[1] / 1000), # convert to millisecs |
747
|
|
|
|
|
|
|
), |
748
|
|
|
|
|
|
|
})->insert; |
749
|
|
|
|
|
|
|
} |
750
|
|
|
|
|
|
|
|
751
|
|
|
|
|
|
|
sub _read_sql_file { |
752
|
0
|
|
|
0
|
|
|
my $self = shift; |
753
|
0
|
|
0
|
|
|
|
my $file = shift || return; |
754
|
|
|
|
|
|
|
|
755
|
0
|
0
|
|
|
|
|
open my $fh, '<', $file or carp("Can't open upgrade file, $file ($!)"); |
756
|
0
|
|
|
|
|
|
my @data = split /\n/, join '', <$fh>; |
757
|
0
|
|
|
|
|
|
close $fh; |
758
|
|
|
|
|
|
|
|
759
|
|
|
|
|
|
|
@data = split /;/, |
760
|
|
|
|
|
|
|
join '', |
761
|
0
|
0
|
0
|
|
|
|
grep { $_ && |
|
0
|
|
|
|
|
|
|
762
|
|
|
|
|
|
|
!/^--/ && |
763
|
|
|
|
|
|
|
!/^(BEGIN|BEGIN TRANSACTION|COMMIT)/mi } |
764
|
|
|
|
|
|
|
@data; |
765
|
|
|
|
|
|
|
|
766
|
0
|
|
|
|
|
|
return \@data; |
767
|
|
|
|
|
|
|
} |
768
|
|
|
|
|
|
|
|
769
|
|
|
|
|
|
|
sub _source_exists |
770
|
|
|
|
|
|
|
{ |
771
|
0
|
|
|
0
|
|
|
my ($self, $rs) = @_; |
772
|
|
|
|
|
|
|
|
773
|
|
|
|
|
|
|
( dbic_internal_try { |
774
|
0
|
|
|
0
|
|
|
$rs->search_rs( UNRESOLVABLE_CONDITION )->cursor->next; |
775
|
0
|
|
|
|
|
|
1; |
776
|
|
|
|
|
|
|
} ) |
777
|
0
|
0
|
|
|
|
|
? 1 |
778
|
|
|
|
|
|
|
: 0 |
779
|
|
|
|
|
|
|
; |
780
|
|
|
|
|
|
|
} |
781
|
|
|
|
|
|
|
|
782
|
|
|
|
|
|
|
=head1 FURTHER QUESTIONS? |
783
|
|
|
|
|
|
|
|
784
|
|
|
|
|
|
|
Check the list of L. |
785
|
|
|
|
|
|
|
|
786
|
|
|
|
|
|
|
=head1 COPYRIGHT AND LICENSE |
787
|
|
|
|
|
|
|
|
788
|
|
|
|
|
|
|
This module is free software L |
789
|
|
|
|
|
|
|
by the L. You can |
790
|
|
|
|
|
|
|
redistribute it and/or modify it under the same terms as the |
791
|
|
|
|
|
|
|
L. |
792
|
|
|
|
|
|
|
|
793
|
|
|
|
|
|
|
=cut |
794
|
|
|
|
|
|
|
|
795
|
|
|
|
|
|
|
1; |