1 package DBIx::Class::DeploymentHandler::DeployMethod::SQL::Translator;
3 use Method::Signatures::Simple;
6 require SQL::Translator::Diff;
7 require DBIx::Class::Storage; # loaded for type constraint
11 with 'DBIx::Class::DeploymentHandler::HandlesDeploy';
16 isa => 'DBIx::Class::Schema',
19 handles => [qw( schema_version )],
23 isa => 'DBIx::Class::Storage',
28 method _build_storage {
29 my $s = $self->schema->storage;
30 $s->_determine_driver;
37 default => sub { {} },
39 has upgrade_directory => (
48 isa => 'DBIx::Class::DeploymentHandler::Databases',
50 default => sub { [qw( MySQL SQLite PostgreSQL )] },
54 isa => 'ArrayRef[Str]',
58 method __ddl_consume_with_prefix($type, $versions, $prefix) {
59 my $base_dir = $self->upgrade_directory;
61 my $main = File::Spec->catfile( $base_dir, $type );
62 my $generic = File::Spec->catfile( $base_dir, '_generic' );
63 my $common = File::Spec->catfile( $base_dir, '_common', $prefix, join q(-), @{$versions} );
67 $dir = File::Spec->catfile($main, $prefix, join q(-), @{$versions})
68 } elsif (-d $generic) {
69 $dir = File::Spec->catfile($main, $prefix, join q(-), @{$versions})
74 opendir my($dh), $dir;
75 my %files = map { $_ => "$dir/$_" } grep { /\.sql$/ && -f "$dir/$_" } readdir($dh);
79 opendir my($dh), $common;
80 for my $filename (grep { /\.sql$/ && -f "$common/$_" } readdir($dh)) {
81 unless ($files{$filename}) {
82 $files{$filename} = "$common/$_";
88 return [@files{sort keys %files}]
91 method _ddl_schema_consume_filenames($type, $version) {
92 $self->__ddl_consume_with_prefix($type, [ $version ], 'schema')
95 method _ddl_schema_produce_filename($type, $version) {
96 my $base_dir = $self->upgrade_directory;
97 my $dirname = File::Spec->catfile(
98 $base_dir, $type, 'schema', $version
100 File::Path::mkpath($dirname) unless -d $dirname;
102 return File::Spec->catfile(
103 $dirname, '001-auto.sql'
107 method _ddl_schema_up_consume_filenames($type, $versions) {
108 $self->__ddl_consume_with_prefix($type, $versions, 'up')
111 method _ddl_schema_down_consume_filenames($type, $versions) {
112 $self->__ddl_consume_with_prefix($type, $versions, 'down')
115 method _ddl_schema_up_produce_filename($type, $versions) {
116 my $dir = $self->upgrade_directory;
118 my $dirname = File::Spec->catfile(
119 $dir, $type, 'up', join( q(-), @{$versions} )
121 File::Path::mkpath($dirname) unless -d $dirname;
123 return File::Spec->catfile(
124 $dirname, '001-auto.sql'
128 method _ddl_schema_down_produce_filename($type, $versions, $dir) {
129 my $dirname = File::Spec->catfile(
130 $dir, $type, 'down', join( q(-), @{$versions} )
132 File::Path::mkpath($dirname) unless -d $dirname;
134 return File::Spec->catfile(
135 $dirname, '001-auto.sql'
139 method _deployment_statements {
140 my $dir = $self->upgrade_directory;
141 my $schema = $self->schema;
142 my $type = $self->storage->sqlt_type;
143 my $sqltargs = $self->sqltargs;
144 my $version = $self->schema_version;
146 my @filenames = @{$self->_ddl_schema_consume_filenames($type, $version)};
148 for my $filename (@filenames) {
151 open $file, q(<), $filename
152 or carp "Can't open $filename ($!)";
155 return join '', @rows;
159 # sources needs to be a parser arg, but for simplicty allow at top level
161 $sqltargs->{parser_args}{sources} = delete $sqltargs->{sources}
162 if exists $sqltargs->{sources};
164 my $tr = SQL::Translator->new(
165 producer => "SQL::Translator::Producer::${type}",
167 parser => 'SQL::Translator::Parser::DBIx::Class',
171 #< frew> now note that deploy in the same file calls deployment_statements
173 #< frew> ALWAYS in array context
174 #< ribasushi> right, that's the only way
175 #< ribasushi> but create_ddl_dir
176 #< ribasushi> calls in scalar
177 #< ribasushi> because this is how you get stuff writable to a file
178 #< ribasushi> in list you get individual statements for dbh->do
181 #< frew> so for *me* I need it *always* in scalar
182 #< frew> because I *only* use it to generate the file
183 #< ribasushi> correct
187 @ret = $tr->translate;
190 $ret[0] = $tr->translate;
193 $schema->throw_exception( 'Unable to produce deployment statements: ' . $tr->error)
194 unless (@ret && defined $ret[0]);
196 return $wa ? @ret : $ret[0];
201 my $storage = $self->storage;
205 #< frew> k, also, we filter out comments and transaction stuff and blank lines
206 #< frew> is that really necesary?
207 #< frew> and what if I want to run my upgrade in a txn? seems like something you'd
208 # always want to do really
209 #< ribasushi> again - some stuff chokes
210 #< frew> ok, so I see filtering out -- and \s*
211 #< frew> but I think the txn filtering should be optional and default to NOT filter it
213 #< ribasushi> then you have a problem
215 #< ribasushi> someone runs a deploy in txn_do
216 #< ribasushi> the inner begin will blow up
217 #< frew> because it's a nested TXN?
218 #< ribasushi> (you an't begin twice on most dbs)
220 #< ribasushi> on sqlite - for sure
221 #< frew> so...read the docs and set txn_filter to true?
222 #< ribasushi> more like wrap deploy in a txn
223 #< frew> I like that better
224 #< ribasushi> and make sure the ddl has no literal txns in them
226 #< ribasushi> this way you have stuff under control
227 #< frew> so we have txn_wrap default to true
228 #< frew> and if people wanna do that by hand they can
230 return if(!$line || $line =~ /^--|^BEGIN TRANSACTION|^COMMIT|^\s+$/);
231 $storage->_query_start($line);
233 # do a dbh_do cycle here, as we need some error checking in
234 # place (even though we will ignore errors)
235 $storage->dbh_do (sub { $_[1]->do($line) });
238 carp "$_ (running '${line}')"
240 $storage->_query_end($line);
242 my @statements = $self->_deployment_statements();
243 if (@statements > 1) {
244 foreach my $statement (@statements) {
245 $deploy->( $statement );
248 elsif (@statements == 1) {
249 foreach my $line ( split(";\n", $statements[0])) {
255 sub prepare_install {
257 my $schema = $self->schema;
258 my $databases = $self->databases;
259 my $dir = $self->upgrade_directory;
260 my $sqltargs = $self->sqltargs;
261 my $version = $schema->schema_version;
264 carp "Upgrade directory $dir does not exist, using ./\n";
269 my $sqlt = SQL::Translator->new({
271 ignore_constraint_names => 1,
272 ignore_index_names => 1,
273 parser => 'SQL::Translator::Parser::DBIx::Class',
277 my $sqlt_schema = $sqlt->translate({ data => $schema })
278 or $self->throw_exception ($sqlt->error);
280 foreach my $db (@$databases) {
282 $sqlt->{schema} = $sqlt_schema;
283 $sqlt->producer($db);
285 my $filename = $self->_ddl_schema_produce_filename($db, $version, $dir);
287 carp "Overwriting existing DDL file - $filename";
291 my $output = $sqlt->translate;
293 carp("Failed to translate to $db, skipping. (" . $sqlt->error . ")");
297 unless( open $file, q(>), $filename ) {
298 $self->throw_exception("Can't open $filename for writing ($!)");
301 print {$file} $output;
306 sub prepare_upgrade {
307 my ($self, $from_version, $to_version, $version_set) = @_;
309 $from_version ||= $self->db_version;
310 $to_version ||= $self->schema_version;
312 # for updates prepared automatically (rob's stuff)
313 # one would want to explicitly set $version_set to
315 $version_set ||= [$from_version, $to_version];
317 $self->_prepare_changegrade($from_version, $to_version, $version_set, 'up');
320 sub prepare_downgrade {
321 my ($self, $from_version, $to_version, $version_set) = @_;
323 $from_version ||= $self->db_version;
324 $to_version ||= $self->schema_version;
326 # for updates prepared automatically (rob's stuff)
327 # one would want to explicitly set $version_set to
329 $version_set ||= [$from_version, $to_version];
331 $self->_prepare_changegrade($from_version, $to_version, $version_set, 'down');
334 method _prepare_changegrade($from_version, $to_version, $version_set, $direction) {
335 my $schema = $self->schema;
336 my $databases = $self->databases;
337 my $dir = $self->upgrade_directory;
338 my $sqltargs = $self->sqltargs;
340 my $schema_version = $schema->schema_version;
344 ignore_constraint_names => 1,
345 ignore_index_names => 1,
349 my $sqlt = SQL::Translator->new( $sqltargs );
351 $sqlt->parser('SQL::Translator::Parser::DBIx::Class');
352 my $sqlt_schema = $sqlt->translate({ data => $schema })
353 or $self->throw_exception ($sqlt->error);
355 foreach my $db (@$databases) {
357 $sqlt->{schema} = $sqlt_schema;
358 $sqlt->producer($db);
360 my $prefilename = $self->_ddl_schema_produce_filename($db, $from_version, $dir);
361 unless(-e $prefilename) {
362 carp("No previous schema file found ($prefilename)");
365 my $diff_file_method = "_ddl_schema_${direction}_produce_filename";
366 my $diff_file = $self->$diff_file_method($db, $version_set, $dir );
368 carp("Overwriting existing $direction-diff file - $diff_file");
374 my $t = SQL::Translator->new({
380 $t->parser( $db ) # could this really throw an exception?
381 or $self->throw_exception ($t->error);
383 my $out = $t->translate( $prefilename )
384 or $self->throw_exception ($t->error);
386 $source_schema = $t->schema;
388 $source_schema->name( $prefilename )
389 unless $source_schema->name;
392 # The "new" style of producers have sane normalization and can support
393 # diffing a SQL file against a DBIC->SQLT schema. Old style ones don't
394 # And we have to diff parsed SQL against parsed SQL.
395 my $dest_schema = $sqlt_schema;
397 unless ( "SQL::Translator::Producer::$db"->can('preprocess_schema') ) {
398 my $t = SQL::Translator->new({
404 $t->parser( $db ) # could this really throw an exception?
405 or $self->throw_exception ($t->error);
407 my $filename = $self->_ddl_schema_produce_filename($db, $to_version, $dir);
408 my $out = $t->translate( $filename )
409 or $self->throw_exception ($t->error);
411 $dest_schema = $t->schema;
413 $dest_schema->name( $filename )
414 unless $dest_schema->name;
417 my $diff = SQL::Translator::Diff::schema_diff(
423 unless(open $file, q(>), $diff_file) {
424 $self->throw_exception("Can't write to $diff_file ($!)");
432 method _read_sql_file($file) {
435 open my $fh, '<', $file or carp("Can't open upgrade file, $file ($!)");
436 my @data = split /\n/, join '', <$fh>;
442 !/^(BEGIN|BEGIN TRANSACTION|COMMIT)/m
449 # these are exactly the same for now
450 sub _downgrade_single_step {
452 my @version_set = @{ shift @_ };
453 my @upgrade_files = @{$self->_ddl_schema_up_consume_filenames(
454 $self->storage->sqlt_type,
458 for my $upgrade_file (@upgrade_files) {
459 unless (-f $upgrade_file) {
461 carp "Upgrade not possible, no upgrade file found ($upgrade_file), please create one\n";
465 $self->_filedata($self->_read_sql_file($upgrade_file)); # I don't like this --fREW 2010-02-22
466 $self->schema->txn_do(sub { $self->_do_upgrade });
470 sub _upgrade_single_step {
472 my @version_set = @{ shift @_ };
473 my @upgrade_files = @{$self->_ddl_schema_up_consume_filenames(
474 $self->storage->sqlt_type,
478 for my $upgrade_file (@upgrade_files) {
479 unless (-f $upgrade_file) {
481 carp "Upgrade not possible, no upgrade file found ($upgrade_file), please create one\n";
485 $self->_filedata($self->_read_sql_file($upgrade_file)); # I don't like this --fREW 2010-02-22
486 $self->schema->txn_do(sub { $self->_do_upgrade });
490 method _do_upgrade { $self->_run_upgrade(qr/.*?/) }
492 method _run_upgrade($stm) {
493 return unless $self->_filedata;
494 my @statements = grep { $_ =~ $stm } @{$self->_filedata};
497 $self->storage->debugobj->query_start($_) if $self->storage->debug;
498 $self->_apply_statement($_);
499 $self->storage->debugobj->query_end($_) if $self->storage->debug;
503 method _apply_statement($statement) {
505 $self->storage->dbh->do($_) or carp "SQL was: $_"
512 vim: ts=2 sw=2 expandtab