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