Commit | Line | Data |
b974984a |
1 | package DBIx::Class::DeploymentHandler; |
2 | |
3 | use Moose; |
4 | use Method::Signatures::Simple; |
12fdd461 |
5 | require DBIx::Class::Schema; # loaded for type constraint |
6 | require DBIx::Class::Storage; # loaded for type constraint |
7 | require DBIx::Class::ResultSet; # loaded for type constraint |
e1f67607 |
8 | use Carp::Clan '^DBIx::Class::DeploymentHandler'; |
ecc3b6be |
9 | use SQL::Translator; |
b974984a |
10 | |
11 | has schema => ( |
61847972 |
12 | isa => 'DBIx::Class::Schema', |
13 | is => 'ro', |
14 | required => 1, |
4ea147c6 |
15 | handles => [qw( ddl_filename schema_version )], |
b974984a |
16 | ); |
17 | |
18 | has upgrade_directory => ( |
61847972 |
19 | isa => 'Str', |
20 | is => 'ro', |
21 | required => 1, |
4ea147c6 |
22 | default => 'sql', |
b974984a |
23 | ); |
24 | |
25 | has backup_directory => ( |
61847972 |
26 | isa => 'Str', |
27 | is => 'ro', |
b974984a |
28 | ); |
29 | |
30 | has storage => ( |
61847972 |
31 | isa => 'DBIx::Class::Storage', |
32 | is => 'ro', |
33 | lazy_build => 1, |
b974984a |
34 | ); |
35 | |
7eec7eb7 |
36 | method _build_storage { |
61847972 |
37 | my $s = $self->schema->storage; |
38 | $s->_determine_driver; |
39 | $s |
7eec7eb7 |
40 | } |
12fdd461 |
41 | |
b974984a |
42 | has _filedata => ( |
4ea147c6 |
43 | isa => 'ArrayRef[Str]', |
61847972 |
44 | is => 'rw', |
b974984a |
45 | ); |
46 | |
47 | has do_backup => ( |
61847972 |
48 | isa => 'Bool', |
49 | is => 'ro', |
50 | default => undef, |
b974984a |
51 | ); |
52 | |
53 | has do_diff_on_init => ( |
61847972 |
54 | isa => 'Bool', |
55 | is => 'ro', |
56 | default => undef, |
b974984a |
57 | ); |
58 | |
12fdd461 |
59 | has version_rs => ( |
61847972 |
60 | isa => 'DBIx::Class::ResultSet', |
61 | is => 'ro', |
62 | lazy_build => 1, |
63 | handles => [qw( is_installed db_version )], |
12fdd461 |
64 | ); |
65 | |
9e401dc2 |
66 | has databases => ( |
67 | # make this coerce from Str |
68 | isa => 'ArrayRef[Str]', |
69 | is => 'ro', |
70 | default => sub { [qw( MySQL SQLite PostgreSQL )] }, |
71 | ); |
72 | |
ecc3b6be |
73 | has sqltargs => ( |
74 | isa => 'HashRef', |
75 | is => 'ro', |
76 | default => sub { {} }, |
77 | ); |
78 | |
30749dbf |
79 | method _build_version_rs { |
80 | $self->schema->set_us_up_the_bomb; |
81 | $self->schema->resultset('__VERSION') |
82 | } |
12fdd461 |
83 | |
84 | method backup { $self->storage->backup($self->backup_directory) } |
b974984a |
85 | |
86 | method install($new_version) { |
12fdd461 |
87 | carp 'Install not possible as versions table already exists in database' |
ceef4ff5 |
88 | if $self->is_installed; |
b974984a |
89 | |
12fdd461 |
90 | $new_version ||= $self->schema_version; |
b974984a |
91 | |
92 | if ($new_version) { |
12fdd461 |
93 | $self->schema->deploy; |
94 | |
95 | $self->version_rs->create({ |
61847972 |
96 | version => $new_version, |
97 | # ddl => $ddl, |
98 | # upgrade_sql => $upgrade_sql, |
12fdd461 |
99 | }); |
b974984a |
100 | } |
101 | } |
102 | |
12fdd461 |
103 | method create_upgrade_path { } |
b974984a |
104 | |
8636376a |
105 | method ordered_schema_versions { undef } |
b974984a |
106 | |
107 | method upgrade { |
12fdd461 |
108 | my $db_version = $self->db_version; |
109 | my $schema_version = $self->schema_version; |
b974984a |
110 | |
b974984a |
111 | unless ($db_version) { |
61847972 |
112 | # croak? |
113 | carp 'Upgrade not possible as database is unversioned. Please call install first.'; |
114 | return; |
b974984a |
115 | } |
116 | |
12fdd461 |
117 | if ( $db_version eq $schema_version ) { |
61847972 |
118 | # croak? |
119 | carp "Upgrade not necessary\n"; |
120 | return; |
b974984a |
121 | } |
122 | |
12fdd461 |
123 | my @version_list = $self->ordered_schema_versions || |
124 | ( $db_version, $schema_version ); |
b974984a |
125 | |
126 | # remove all versions in list above the required version |
12fdd461 |
127 | while ( @version_list && ( $version_list[-1] ne $schema_version ) ) { |
61847972 |
128 | pop @version_list; |
b974984a |
129 | } |
130 | |
131 | # remove all versions in list below the current version |
12fdd461 |
132 | while ( @version_list && ( $version_list[0] ne $db_version ) ) { |
61847972 |
133 | shift @version_list; |
b974984a |
134 | } |
135 | |
136 | # check we have an appropriate list of versions |
12fdd461 |
137 | die if @version_list < 2; |
b974984a |
138 | |
139 | # do sets of upgrade |
12fdd461 |
140 | while ( @version_list >= 2 ) { |
61847972 |
141 | $self->upgrade_single_step( $version_list[0], $version_list[1] ); |
142 | shift @version_list; |
b974984a |
143 | } |
144 | } |
145 | |
146 | method upgrade_single_step($db_version, $target_version) { |
b974984a |
147 | if ($db_version eq $target_version) { |
e1f67607 |
148 | # croak? |
b974984a |
149 | carp "Upgrade not necessary\n"; |
150 | return; |
151 | } |
152 | |
b974984a |
153 | my $upgrade_file = $self->ddl_filename( |
12fdd461 |
154 | $self->storage->sqlt_type, |
155 | $target_version, |
156 | $self->upgrade_directory, |
157 | $db_version, |
158 | ); |
b974984a |
159 | |
160 | $self->create_upgrade_path({ upgrade_file => $upgrade_file }); |
161 | |
162 | unless (-f $upgrade_file) { |
e1f67607 |
163 | # croak? |
b974984a |
164 | carp "Upgrade not possible, no upgrade file found ($upgrade_file), please create one\n"; |
165 | return; |
166 | } |
167 | |
168 | carp "DB version ($db_version) is lower than the schema version (".$self->schema_version."). Attempting upgrade.\n"; |
169 | |
e1f67607 |
170 | $self->_filedata($self->_read_sql_file($upgrade_file)); # I don't like this --fREW 2010-02-22 |
12fdd461 |
171 | $self->backup if $self->do_backup; |
172 | $self->schema->txn_do(sub { $self->do_upgrade }); |
b974984a |
173 | |
12fdd461 |
174 | $self->version_rs->create({ |
61847972 |
175 | version => $target_version, |
176 | # ddl => $ddl, |
177 | # upgrade_sql => $upgrade_sql, |
12fdd461 |
178 | }); |
b974984a |
179 | } |
180 | |
ecc3b6be |
181 | method create_ddl_dir($version, $preversion) { |
182 | my $schema = $self->schema; |
9e401dc2 |
183 | my $databases = $self->databases; |
ecc3b6be |
184 | my $dir = $self->upgrade_directory; |
185 | my $sqltargs = $self->sqltargs; |
9e401dc2 |
186 | unless( -d $dir ) { |
187 | carp "Upgrade directory $dir does not exist, using ./\n"; |
8164e4d0 |
188 | $dir = "./"; |
189 | } |
8164e4d0 |
190 | |
191 | my $schema_version = $schema->schema_version || '1.x'; |
192 | $version ||= $schema_version; |
193 | |
194 | $sqltargs = { |
195 | add_drop_table => 1, |
196 | ignore_constraint_names => 1, |
197 | ignore_index_names => 1, |
198 | %{$sqltargs || {}} |
199 | }; |
200 | |
8164e4d0 |
201 | my $sqlt = SQL::Translator->new( $sqltargs ); |
202 | |
203 | $sqlt->parser('SQL::Translator::Parser::DBIx::Class'); |
204 | my $sqlt_schema = $sqlt->translate({ data => $schema }) |
205 | or $self->throw_exception ($sqlt->error); |
206 | |
207 | foreach my $db (@$databases) { |
c88c9aaa |
208 | $sqlt->reset; |
8164e4d0 |
209 | $sqlt->{schema} = $sqlt_schema; |
210 | $sqlt->producer($db); |
211 | |
c88c9aaa |
212 | my $filename = $self->ddl_filename($db, $version, $dir); |
8164e4d0 |
213 | if (-e $filename && ($version eq $schema_version )) { |
214 | # if we are dumping the current version, overwrite the DDL |
215 | carp "Overwriting existing DDL file - $filename"; |
c88c9aaa |
216 | unlink $filename; |
8164e4d0 |
217 | } |
218 | |
219 | my $output = $sqlt->translate; |
220 | if(!$output) { |
221 | carp("Failed to translate to $db, skipping. (" . $sqlt->error . ")"); |
222 | next; |
223 | } |
c88c9aaa |
224 | my $file; |
225 | unless( open $file, q(>), $filename ) { |
8164e4d0 |
226 | $self->throw_exception("Can't open $filename for writing ($!)"); |
227 | next; |
228 | } |
c88c9aaa |
229 | print {$file} $output; |
230 | close $file; |
8164e4d0 |
231 | |
c88c9aaa |
232 | next unless $preversion; |
8164e4d0 |
233 | |
234 | require SQL::Translator::Diff; |
235 | |
c88c9aaa |
236 | my $prefilename = $self->ddl_filename($db, $preversion, $dir); |
237 | unless(-e $prefilename) { |
8164e4d0 |
238 | carp("No previous schema file found ($prefilename)"); |
239 | next; |
240 | } |
241 | |
c88c9aaa |
242 | my $diff_file = $self->ddl_filename($db, $version, $dir, $preversion); |
243 | if(-e $diff_file) { |
244 | carp("Overwriting existing diff file - $diff_file"); |
245 | unlink $diff_file; |
8164e4d0 |
246 | } |
247 | |
248 | my $source_schema; |
249 | { |
c88c9aaa |
250 | my $t = SQL::Translator->new({ |
251 | %{$sqltargs}, |
252 | debug => 0, |
253 | trace => 0, |
254 | }); |
8164e4d0 |
255 | |
c88c9aaa |
256 | $t->parser( $db ) # could this really throw an exception? |
8164e4d0 |
257 | or $self->throw_exception ($t->error); |
258 | |
259 | my $out = $t->translate( $prefilename ) |
260 | or $self->throw_exception ($t->error); |
261 | |
262 | $source_schema = $t->schema; |
263 | |
264 | $source_schema->name( $prefilename ) |
c88c9aaa |
265 | unless $source_schema->name; |
8164e4d0 |
266 | } |
267 | |
268 | # The "new" style of producers have sane normalization and can support |
269 | # diffing a SQL file against a DBIC->SQLT schema. Old style ones don't |
270 | # And we have to diff parsed SQL against parsed SQL. |
271 | my $dest_schema = $sqlt_schema; |
272 | |
273 | unless ( "SQL::Translator::Producer::$db"->can('preprocess_schema') ) { |
c88c9aaa |
274 | my $t = SQL::Translator->new({ |
275 | %{$sqltargs}, |
276 | debug => 0, |
277 | trace => 0, |
278 | }); |
8164e4d0 |
279 | |
c88c9aaa |
280 | $t->parser( $db ) # could this really throw an exception? |
8164e4d0 |
281 | or $self->throw_exception ($t->error); |
282 | |
283 | my $out = $t->translate( $filename ) |
284 | or $self->throw_exception ($t->error); |
285 | |
286 | $dest_schema = $t->schema; |
287 | |
288 | $dest_schema->name( $filename ) |
289 | unless $dest_schema->name; |
290 | } |
291 | |
c88c9aaa |
292 | my $diff = SQL::Translator::Diff::schema_diff( |
293 | $source_schema, $db, |
294 | $dest_schema, $db, |
295 | $sqltargs |
296 | ); |
297 | unless(open $file, q(>), $diff_file) { |
298 | $self->throw_exception("Can't write to $diff_file ($!)"); |
8164e4d0 |
299 | next; |
300 | } |
c88c9aaa |
301 | print {$file} $diff; |
302 | close $file; |
8164e4d0 |
303 | } |
304 | } |
305 | |
12fdd461 |
306 | method do_upgrade { $self->run_upgrade(qr/.*?/) } |
b974984a |
307 | |
308 | method run_upgrade($stm) { |
12fdd461 |
309 | return unless $self->_filedata; |
310 | my @statements = grep { $_ =~ $stm } @{$self->_filedata}; |
b974984a |
311 | |
12fdd461 |
312 | for (@statements) { |
313 | $self->storage->debugobj->query_start($_) if $self->storage->debug; |
314 | $self->apply_statement($_); |
315 | $self->storage->debugobj->query_end($_) if $self->storage->debug; |
316 | } |
b974984a |
317 | } |
318 | |
319 | method apply_statement($statement) { |
e1f67607 |
320 | # croak? |
12fdd461 |
321 | $self->storage->dbh->do($_) or carp "SQL was: $_" |
b974984a |
322 | } |
323 | |
8cf0010a |
324 | method _read_sql_file($file) { |
325 | return unless $file; |
b974984a |
326 | |
327 | open my $fh, '<', $file or carp("Can't open upgrade file, $file ($!)"); |
328 | my @data = split /\n/, join '', <$fh>; |
329 | close $fh; |
330 | |
331 | @data = grep { |
8cf0010a |
332 | $_ && |
333 | !/^--/ && |
334 | !/^(BEGIN|BEGIN TRANSACTION|COMMIT)/m |
b974984a |
335 | } split /;/, |
8cf0010a |
336 | join '', @data; |
b974984a |
337 | |
338 | return \@data; |
339 | } |
340 | |
b974984a |
341 | 1; |
61847972 |
342 | |
343 | __END__ |
344 | |
345 | vim: ts=2,sw=2,expandtab |