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
9 with 'DBIx::Class::DeploymentHandler::HandlesDeploy';
13 isa => 'DBIx::Class::Storage',
18 method _build_storage {
19 my $s = $self->schema->storage;
20 $s->_determine_driver;
24 has backup_directory => (
38 default => sub { {} },
40 has upgrade_directory => (
48 isa => 'DBIx::Class::ResultSet',
51 handles => [qw( is_installed db_version )],
54 method _build_version_rs {
55 $self->schema->set_us_up_the_bomb;
56 $self->schema->resultset('__VERSION')
61 isa => 'DBIx::Class::DeploymentHandler::Databases',
63 default => sub { [qw( MySQL SQLite PostgreSQL )] },
67 isa => 'DBIx::Class::Schema',
70 handles => [qw( schema_version )],
74 isa => 'ArrayRef[Str]',
78 method _ddl_filename($type, $versions, $dir) {
79 my $filename = ref $self->schema;
80 $filename =~ s/::/-/g;
82 $filename = File::Spec->catfile(
83 $dir, "$filename-" . join( q(-), @{$versions} ) . "-$type.sql"
89 method _deployment_statements {
90 my $dir = $self->upgrade_directory;
91 my $schema = $self->schema;
92 my $type = $self->storage->sqlt_type;
93 my $sqltargs = $self->sqltargs;
94 my $version = $self->schema_version || '1.x';
96 my $filename = $self->_ddl_filename($type, [ $version ], $dir);
99 open $file, q(<), $filename
100 or carp "Can't open $filename ($!)";
103 return join '', @rows;
106 # sources needs to be a parser arg, but for simplicty allow at top level
108 $sqltargs->{parser_args}{sources} = delete $sqltargs->{sources}
109 if exists $sqltargs->{sources};
111 my $tr = SQL::Translator->new(
112 producer => "SQL::Translator::Producer::${type}",
114 parser => 'SQL::Translator::Parser::DBIx::Class',
121 @ret = $tr->translate;
124 $ret[0] = $tr->translate;
127 $schema->throw_exception( 'Unable to produce deployment statements: ' . $tr->error)
128 unless (@ret && defined $ret[0]);
130 return $wa ? @ret : $ret[0];
135 my $storage = $self->storage;
139 return if(!$line || $line =~ /^--|^BEGIN TRANSACTION|^COMMIT|^\s+$/);
140 $storage->_query_start($line);
142 # do a dbh_do cycle here, as we need some error checking in
143 # place (even though we will ignore errors)
144 $storage->dbh_do (sub { $_[1]->do($line) });
147 carp "$_ (running '${line}')"
149 $storage->_query_end($line);
151 my @statements = $self->_deployment_statements();
152 if (@statements > 1) {
153 foreach my $statement (@statements) {
154 $deploy->( $statement );
157 elsif (@statements == 1) {
158 foreach my $line ( split(";\n", $statements[0])) {
164 sub prepare_install {
166 my $schema = $self->schema;
167 my $databases = $self->databases;
168 my $dir = $self->upgrade_directory;
169 my $sqltargs = $self->sqltargs;
171 carp "Upgrade directory $dir does not exist, using ./\n";
175 my $version = $schema->schema_version || '1.x';
176 my $schema_version = $schema->schema_version || '1.x';
177 $version ||= $schema_version;
181 ignore_constraint_names => 1,
182 ignore_index_names => 1,
186 my $sqlt = SQL::Translator->new( $sqltargs );
188 $sqlt->parser('SQL::Translator::Parser::DBIx::Class');
189 my $sqlt_schema = $sqlt->translate({ data => $schema })
190 or $self->throw_exception ($sqlt->error);
192 foreach my $db (@$databases) {
194 $sqlt->{schema} = $sqlt_schema;
195 $sqlt->producer($db);
197 my $filename = $self->_ddl_filename($db, [ $version ], $dir);
198 if (-e $filename && ($version eq $schema_version )) {
199 # if we are dumping the current version, overwrite the DDL
200 carp "Overwriting existing DDL file - $filename";
204 my $output = $sqlt->translate;
206 carp("Failed to translate to $db, skipping. (" . $sqlt->error . ")");
210 unless( open $file, q(>), $filename ) {
211 $self->throw_exception("Can't open $filename for writing ($!)");
214 print {$file} $output;
220 my ($self, $version, $preversion) = @_;
221 my $schema = $self->schema;
222 my $databases = $self->databases;
223 my $dir = $self->upgrade_directory;
224 my $sqltargs = $self->sqltargs;
227 carp "Upgrade directory $dir does not exist, using ./\n";
231 my $schema_version = $schema->schema_version || '1.x';
232 $version ||= $schema_version;
236 ignore_constraint_names => 1,
237 ignore_index_names => 1,
241 my $sqlt = SQL::Translator->new( $sqltargs );
243 $sqlt->parser('SQL::Translator::Parser::DBIx::Class');
244 my $sqlt_schema = $sqlt->translate({ data => $schema })
245 or $self->throw_exception ($sqlt->error);
247 foreach my $db (@$databases) {
249 $sqlt->{schema} = $sqlt_schema;
250 $sqlt->producer($db);
252 my $prefilename = $self->_ddl_filename($db, [ $preversion ], $dir);
253 unless(-e $prefilename) {
254 carp("No previous schema file found ($prefilename)");
258 my $diff_file = $self->_ddl_filename($db, [ $preversion, $version ], $dir );
260 carp("Overwriting existing diff file - $diff_file");
266 my $t = SQL::Translator->new({
272 $t->parser( $db ) # could this really throw an exception?
273 or $self->throw_exception ($t->error);
275 my $out = $t->translate( $prefilename )
276 or $self->throw_exception ($t->error);
278 $source_schema = $t->schema;
280 $source_schema->name( $prefilename )
281 unless $source_schema->name;
284 # The "new" style of producers have sane normalization and can support
285 # diffing a SQL file against a DBIC->SQLT schema. Old style ones don't
286 # And we have to diff parsed SQL against parsed SQL.
287 my $dest_schema = $sqlt_schema;
289 unless ( "SQL::Translator::Producer::$db"->can('preprocess_schema') ) {
290 my $t = SQL::Translator->new({
296 $t->parser( $db ) # could this really throw an exception?
297 or $self->throw_exception ($t->error);
299 my $filename = $self->_ddl_filename($db, [ $version ], $dir);
300 my $out = $t->translate( $filename )
301 or $self->throw_exception ($t->error);
303 $dest_schema = $t->schema;
305 $dest_schema->name( $filename )
306 unless $dest_schema->name;
309 my $diff = SQL::Translator::Diff::schema_diff(
315 unless(open $file, q(>), $diff_file) {
316 $self->throw_exception("Can't write to $diff_file ($!)");
324 method _read_sql_file($file) {
327 open my $fh, '<', $file or carp("Can't open upgrade file, $file ($!)");
328 my @data = split /\n/, join '', <$fh>;
334 !/^(BEGIN|BEGIN TRANSACTION|COMMIT)/m
341 sub _upgrade_single_step {
343 my @version_set = @{ shift @_ };
344 my $db_version = $self->db_version;
345 my $upgrade_file = $self->_ddl_filename(
346 $self->storage->sqlt_type,
348 $self->upgrade_directory,
351 unless (-f $upgrade_file) {
353 carp "Upgrade not possible, no upgrade file found ($upgrade_file), please create one\n";
357 carp "DB version ($db_version) is lower than the schema version (".$self->schema_version."). Attempting upgrade.\n";
359 $self->_filedata($self->_read_sql_file($upgrade_file)); # I don't like this --fREW 2010-02-22
360 $self->backup if $self->do_backup;
361 $self->schema->txn_do(sub { $self->_do_upgrade });
363 $self->version_rs->create({
364 version => $version_set[-1],
366 # upgrade_sql => $upgrade_sql,
370 method _do_upgrade { $self->_run_upgrade(qr/.*?/) }
372 method _run_upgrade($stm) {
373 return unless $self->_filedata;
374 my @statements = grep { $_ =~ $stm } @{$self->_filedata};
377 $self->storage->debugobj->query_start($_) if $self->storage->debug;
378 $self->_apply_statement($_);
379 $self->storage->debugobj->query_end($_) if $self->storage->debug;
383 method _apply_statement($statement) {
385 $self->storage->dbh->do($_) or carp "SQL was: $_"
388 method backup { $self->storage->backup($self->backup_directory) }
390 __PACKAGE__->meta->make_immutable;
396 vim: ts=2 sw=2 expandtab