1 package DBIx::Class::DeploymentHandler::DeployMethod::SQL::Translator;
5 use Carp qw( carp croak );
7 use Method::Signatures::Simple;
11 require SQL::Translator::Diff;
13 require DBIx::Class::Storage; # loaded for type constraint
14 use DBIx::Class::DeploymentHandler::Types;
16 use File::Path 'mkpath';
17 use File::Spec::Functions;
19 with 'DBIx::Class::DeploymentHandler::HandlesDeploy';
22 isa => 'DBIx::Class::Schema',
25 handles => [qw( schema_version )],
29 isa => 'DBIx::Class::Storage',
34 method _build_storage {
35 my $s = $self->schema->storage;
36 $s->_determine_driver;
43 default => sub { {} },
45 has upgrade_directory => (
54 isa => 'DBIx::Class::DeploymentHandler::Databases',
56 default => sub { [qw( MySQL SQLite PostgreSQL )] },
65 method __ddl_consume_with_prefix($type, $versions, $prefix) {
66 my $base_dir = $self->upgrade_directory;
68 my $main = catfile( $base_dir, $type );
69 my $generic = catfile( $base_dir, '_generic' );
71 catfile( $base_dir, '_common', $prefix, join q(-), @{$versions} );
75 $dir = catfile($main, $prefix, join q(-), @{$versions})
76 } elsif (-d $generic) {
77 $dir = catfile($generic, $prefix, join q(-), @{$versions});
79 croak "neither $main or $generic exist; please write/generate some SQL";
82 opendir my($dh), $dir;
83 my %files = map { $_ => "$dir/$_" } grep { /\.(?:sql|pl)$/ && -f "$dir/$_" } readdir $dh;
87 opendir my($dh), $common;
88 for my $filename (grep { /\.(?:sql|pl)$/ && -f catfile($common,$_) } readdir $dh) {
89 unless ($files{$filename}) {
90 $files{$filename} = catfile($common,$filename);
96 return [@files{sort keys %files}]
99 method _ddl_schema_consume_filenames($type, $version) {
100 $self->__ddl_consume_with_prefix($type, [ $version ], 'schema')
103 method _ddl_schema_produce_filename($type, $version) {
104 my $dirname = catfile( $self->upgrade_directory, $type, 'schema', $version );
105 mkpath($dirname) unless -d $dirname;
107 return catfile( $dirname, '001-auto.sql' );
110 method _ddl_schema_up_consume_filenames($type, $versions) {
111 $self->__ddl_consume_with_prefix($type, $versions, 'up')
114 method _ddl_schema_down_consume_filenames($type, $versions) {
115 $self->__ddl_consume_with_prefix($type, $versions, 'down')
118 method _ddl_schema_up_produce_filename($type, $versions) {
119 my $dir = $self->upgrade_directory;
121 my $dirname = catfile( $dir, $type, 'up', join q(-), @{$versions});
122 mkpath($dirname) unless -d $dirname;
124 return catfile( $dirname, '001-auto.sql'
128 method _ddl_schema_down_produce_filename($type, $versions, $dir) {
129 my $dirname = catfile( $dir, $type, 'down', join q(-), @{$versions} );
130 mkpath($dirname) unless -d $dirname;
132 return catfile( $dirname, '001-auto.sql');
135 method _run_sql_and_perl($filenames) {
136 my @files = @{$filenames};
137 my $storage = $self->storage;
140 my $guard = $self->schema->txn_scope_guard if $self->txn_wrap;
143 for my $filename (@files) {
144 if ($filename =~ /\.sql$/) {
145 my @sql = @{$self->_read_sql_file($filename)};
146 $sql .= join "\n", @sql;
148 foreach my $line (@sql) {
149 $storage->_query_start($line);
151 # do a dbh_do cycle here, as we need some error checking in
152 # place (even though we will ignore errors)
153 $storage->dbh_do (sub { $_[1]->do($line) });
156 carp "$_ (running '${line}')"
158 $storage->_query_end($line);
160 } elsif ( $filename =~ /^(.+)\.pl$/ ) {
162 my $filedata = do { local( @ARGV, $/ ) = $filename; <> };
163 # make the package name more palateable to perl
164 $package =~ s/\W/_/g;
166 no warnings 'redefine';
167 eval "package $package;\n\n$filedata";
170 if (my $fn = $package->can('run')) {
171 $fn->($self->schema);
173 carp "$filename should define a run method that takes a schema but it didn't!";
176 croak "A file got to deploy that wasn't sql or perl!";
180 $guard->commit if $self->txn_wrap;
188 return $self->_run_sql_and_perl($self->_ddl_schema_consume_filenames(
189 $self->storage->sqlt_type,
190 $self->schema_version
194 sub _prepare_install {
196 my $sqltargs = { %{$self->sqltargs}, %{shift @_} };
198 my $schema = $self->schema;
199 my $databases = $self->databases;
200 my $dir = $self->upgrade_directory;
201 my $version = $schema->schema_version;
203 my $sqlt = SQL::Translator->new({
205 ignore_constraint_names => 1,
206 ignore_index_names => 1,
207 parser => 'SQL::Translator::Parser::DBIx::Class',
211 my $sqlt_schema = $sqlt->translate( data => $schema )
212 or croak($sqlt->error);
214 foreach my $db (@$databases) {
216 $sqlt->{schema} = $sqlt_schema;
217 $sqlt->producer($db);
219 my $filename = $self->$to_file($db, $version, $dir);
221 carp "Overwriting existing DDL file - $filename";
225 my $output = $sqlt->translate;
227 carp("Failed to translate to $db, skipping. (" . $sqlt->error . ")");
230 open my $file, q(>), $filename;
231 print {$file} $output;
236 sub _resultsource_install_filename {
237 my ($self, $source_name) = @_;
239 my ($self, $type, $version) = @_;
240 my $dirname = catfile( $self->upgrade_directory, $type, 'schema', $version );
241 mkpath($dirname) unless -d $dirname;
243 return catfile( $dirname, "001-auto-$source_name.sql" );
247 sub install_resultsource {
248 my ($self, $source, $version) = @_;
250 my $rs_install_file =
251 $self->_resultsource_install_filename($source->source_name);
254 $self->$rs_install_file(
255 $self->storage->sqlt_type,
259 $self->_run_sql_and_perl($files);
262 sub prepare_resultsource_install {
266 my $filename = $self->_resultsource_install_filename($source->source_name);
267 $self->_prepare_install({
268 parser_args => { sources => [$source->source_name], }
272 sub prepare_install {
274 $self->_prepare_install({}, '_ddl_schema_produce_filename');
277 sub prepare_upgrade {
278 my ($self, $from_version, $to_version, $version_set) = @_;
279 $self->_prepare_changegrade($from_version, $to_version, $version_set, 'up');
282 sub prepare_downgrade {
283 my ($self, $from_version, $to_version, $version_set) = @_;
285 $self->_prepare_changegrade($from_version, $to_version, $version_set, 'down');
288 method _prepare_changegrade($from_version, $to_version, $version_set, $direction) {
289 my $schema = $self->schema;
290 my $databases = $self->databases;
291 my $dir = $self->upgrade_directory;
292 my $sqltargs = $self->sqltargs;
294 my $schema_version = $schema->schema_version;
298 ignore_constraint_names => 1,
299 ignore_index_names => 1,
303 my $sqlt = SQL::Translator->new( $sqltargs );
305 $sqlt->parser('SQL::Translator::Parser::DBIx::Class');
306 my $sqlt_schema = $sqlt->translate( data => $schema )
307 or croak($sqlt->error);
309 foreach my $db (@$databases) {
311 $sqlt->{schema} = $sqlt_schema;
312 $sqlt->producer($db);
314 my $prefilename = $self->_ddl_schema_produce_filename($db, $from_version, $dir);
315 unless(-e $prefilename) {
316 carp("No previous schema file found ($prefilename)");
319 my $diff_file_method = "_ddl_schema_${direction}_produce_filename";
320 my $diff_file = $self->$diff_file_method($db, $version_set, $dir );
322 carp("Overwriting existing $direction-diff file - $diff_file");
328 my $t = SQL::Translator->new({
334 $t->parser( $db ) # could this really throw an exception?
337 my $out = $t->translate( $prefilename )
340 $source_schema = $t->schema;
342 $source_schema->name( $prefilename )
343 unless $source_schema->name;
346 # The "new" style of producers have sane normalization and can support
347 # diffing a SQL file against a DBIC->SQLT schema. Old style ones don't
348 # And we have to diff parsed SQL against parsed SQL.
349 my $dest_schema = $sqlt_schema;
351 unless ( "SQL::Translator::Producer::$db"->can('preprocess_schema') ) {
352 my $t = SQL::Translator->new({
358 $t->parser( $db ) # could this really throw an exception?
361 my $filename = $self->_ddl_schema_produce_filename($db, $to_version, $dir);
362 my $out = $t->translate( $filename )
365 $dest_schema = $t->schema;
367 $dest_schema->name( $filename )
368 unless $dest_schema->name;
371 my $diff = SQL::Translator::Diff::schema_diff(
376 open my $file, q(>), $diff_file;
382 method _read_sql_file($file) {
385 open my $fh, '<', $file;
386 my @data = split /;\n/, join '', <$fh>;
390 $_ && # remove blank lines
391 !/^(BEGIN|BEGIN TRANSACTION|COMMIT)/ # strip txn's
393 s/^\s+//; s/\s+$//; # trim whitespace
394 join '', grep { !/^--/ } split /\n/ # remove comments
400 sub downgrade_single_step {
402 my $version_set = shift @_;
404 my $sql = $self->_run_sql_and_perl($self->_ddl_schema_down_consume_filenames(
405 $self->storage->sqlt_type,
412 sub upgrade_single_step {
414 my $version_set = shift @_;
416 my $sql = $self->_run_sql_and_perl($self->_ddl_schema_up_consume_filenames(
417 $self->storage->sqlt_type,
423 __PACKAGE__->meta->make_immutable;
427 # vim: ts=2 sw=2 expandtab
433 This class is the meat of L<DBIx::Class::DeploymentHandler>. It takes care of
434 generating sql files representing schemata as well as sql files to move from
435 one version of a schema to the rest. One of the hallmark features of this
436 class is that it allows for multiple sql files for deploy and upgrade, allowing
437 developers to fine tune deployment. In addition it also allows for perl files
438 to be run at any stage of the process.
440 For basic usage see L<DBIx::Class::DeploymentHandler::HandlesDeploy>. What's
441 documented here is extra fun stuff or private methods.
443 =head1 DIRECTORY LAYOUT
445 It's heavily based upon L<DBIx::Migration::Directories>.
449 The L<DBIx::Class::Schema> (B<required>) that is used to talk to the database
450 and generate the DDL.
454 The L<DBIx::Class::Storage> that is I<actually> used to talk to the database
455 and generate the DDL. This is automatically created with L</_build_storage>.
461 =attr upgrade_directory
463 The directory (default C<'sql'>) that upgrades are stored in
467 The types of databases (default C<< [qw( MySQL SQLite PostgreSQL )] >>) to
472 Set to true (which is the default) to wrap all upgrades and deploys in a single
475 =method __ddl_consume_with_prefix
477 $dm->__ddl_consume_with_prefix( 'SQLite', [qw( 1.00 1.01 )], 'up' )
479 This is the meat of the multi-file upgrade/deploy stuff. It returns a list of
480 files in the order that they should be run for a generic "type" of upgrade.
481 You should not be calling this in user code.
483 =method _ddl_schema_consume_filenames
485 $dm->__ddl_schema_consume_filenames( 'SQLite', [qw( 1.00 )] )
487 Just a curried L</__ddl_consume_with_prefix>. Get's a list of files for an
490 =method _ddl_schema_produce_filename
492 $dm->__ddl_schema_produce_filename( 'SQLite', [qw( 1.00 )] )
494 Returns a single file in which an initial schema will be stored.
496 =method _ddl_schema_up_consume_filenames
498 $dm->_ddl_schema_up_consume_filenames( 'SQLite', [qw( 1.00 )] )
500 Just a curried L</__ddl_consume_with_prefix>. Get's a list of files for an
503 =method _ddl_schema_down_consume_filenames
505 $dm->_ddl_schema_down_consume_filenames( 'SQLite', [qw( 1.00 )] )
507 Just a curried L</__ddl_consume_with_prefix>. Get's a list of files for a
510 =method _ddl_schema_up_produce_filenames
512 $dm->_ddl_schema_up_produce_filename( 'SQLite', [qw( 1.00 1.01 )] )
514 Returns a single file in which the sql to upgrade from one schema to another
517 =method _ddl_schema_down_produce_filename
519 $dm->_ddl_schema_down_produce_filename( 'SQLite', [qw( 1.00 1.01 )] )
521 Returns a single file in which the sql to downgrade from one schema to another
524 =method _resultsource_install_filename
526 my $filename_fn = $dm->_resultsource_install_filename('User');
527 $dm->$filename_fn('SQLite', '1.00')
529 Returns a function which in turn returns a single filename used to install a
530 single resultsource. Weird interface is convenient for me. Deal with it.
532 =method _run_sql_and_perl
534 $dm->_run_sql_and_perl([qw( list of filenames )])
536 Simply put, this runs the list of files passed to it. If the file ends in
537 C<.sql> it runs it as sql and if it ends in C<.pl> it runs it as a perl file.
539 Depending on L</txn_wrap> all of the files run will be wrapped in a single
542 =method _prepare_install
544 $dm->_prepare_install({ add_drop_table => 0 }, sub { 'file_to_create' })
546 Generates the sql file for installing the database. First arg is simply
547 L<SQL::Translator> args and the second is a coderef that returns the filename
550 =method _prepare_changegrade
552 $dm->_prepare_changegrade('1.00', '1.01', [qw( 1.00 1.01)], 'up')
554 Generates the sql file for migrating from one schema version to another. First
555 arg is the version to start from, second is the version to go to, third is the
556 L<version set|DBIx::Class::DeploymentHandler/VERSION SET>, and last is the
557 direction of the changegrade, be it 'up' or 'down'.
559 =method _read_sql_file
561 $dm->_read_sql_file('foo.sql')
563 Reads a sql file and returns lines in an C<ArrayRef>. Strips out comments,
564 transactions, and blank lines.