1 package DBIx::Class::DeploymentHandler::DeployMethod::SQL::Translator;
4 # ABSTRACT: Manage your SQL and Perl migrations in nicely laid out directories
7 use Carp qw( carp croak );
8 use DBIx::Class::DeploymentHandler::Logger;
9 use Log::Contextual qw(:log :dlog), -default_logger =>
10 DBIx::Class::DeploymentHandler::Logger->new({
11 env_prefix => 'DBICDH'
14 use Method::Signatures::Simple;
18 require SQL::Translator::Diff;
20 require DBIx::Class::Storage; # loaded for type constraint
21 use DBIx::Class::DeploymentHandler::Types;
23 use File::Path 'mkpath';
24 use File::Spec::Functions;
26 with 'DBIx::Class::DeploymentHandler::HandlesDeploy';
29 isa => 'DBIx::Class::Schema',
35 isa => 'DBIx::Class::Storage',
40 method _build_storage {
41 my $s = $self->schema->storage;
42 $s->_determine_driver;
46 has sql_translator_args => (
49 default => sub { {} },
51 has script_directory => (
60 isa => 'DBIx::Class::DeploymentHandler::Databases',
62 default => sub { [qw( MySQL SQLite PostgreSQL )] },
71 has schema_version => (
77 # this will probably never get called as the DBICDH
78 # will be passing down a schema_version normally, which
79 # is built the same way, but we leave this in place
80 method _build_schema_version { $self->schema->schema_version }
87 sub _build__json { require JSON; JSON->new->pretty }
89 method __ddl_consume_with_prefix($type, $versions, $prefix) {
90 my $base_dir = $self->script_directory;
92 my $main = catfile( $base_dir, $type );
93 my $generic = catfile( $base_dir, '_generic' );
95 catfile( $base_dir, '_common', $prefix, join q(-), @{$versions} );
99 $dir = catfile($main, $prefix, join q(-), @{$versions})
100 } elsif (-d $generic) {
101 $dir = catfile($generic, $prefix, join q(-), @{$versions});
103 croak "neither $main or $generic exist; please write/generate some SQL";
106 opendir my($dh), $dir;
107 my %files = map { $_ => "$dir/$_" } grep { /\.(?:sql|pl|sql-\w+)$/ && -f "$dir/$_" } readdir $dh;
111 opendir my($dh), $common;
112 for my $filename (grep { /\.(?:sql|pl)$/ && -f catfile($common,$_) } readdir $dh) {
113 unless ($files{$filename}) {
114 $files{$filename} = catfile($common,$filename);
120 return [@files{sort keys %files}]
123 method _ddl_preinstall_consume_filenames($type, $version) {
124 $self->__ddl_consume_with_prefix($type, [ $version ], 'preinstall')
127 method _ddl_schema_consume_filenames($type, $version) {
128 $self->__ddl_consume_with_prefix($type, [ $version ], 'schema')
131 method _ddl_schema_produce_filename($type, $version) {
132 my $dirname = catfile( $self->script_directory, $type, 'schema', $version );
133 mkpath($dirname) unless -d $dirname;
135 return catfile( $dirname, '001-auto.sql-json' );
138 method _ddl_schema_up_consume_filenames($type, $versions) {
139 $self->__ddl_consume_with_prefix($type, $versions, 'up')
142 method _ddl_schema_down_consume_filenames($type, $versions) {
143 $self->__ddl_consume_with_prefix($type, $versions, 'down')
146 method _ddl_schema_up_produce_filename($type, $versions) {
147 my $dir = $self->script_directory;
149 my $dirname = catfile( $dir, $type, 'up', join q(-), @{$versions});
150 mkpath($dirname) unless -d $dirname;
152 return catfile( $dirname, '001-auto.sql-json' );
155 method _ddl_schema_down_produce_filename($type, $versions, $dir) {
156 my $dirname = catfile( $dir, $type, 'down', join q(-), @{$versions} );
157 mkpath($dirname) unless -d $dirname;
159 return catfile( $dirname, '001-auto.sql-json');
162 method _run_sql_array($sql) {
163 my $storage = $self->storage;
166 $_ && # remove blank lines
167 !/^(BEGIN|BEGIN TRANSACTION|COMMIT)/ # strip txn's
169 s/^\s+//; s/\s+$//; # trim whitespace
170 join '', grep { !/^--/ } split /\n/ # remove comments
173 Dlog_trace { "[DBICDH] Running SQL $_" } $sql;
174 foreach my $line (@{$sql}) {
175 $storage->_query_start($line);
176 # the whole reason we do this is so that we can see the line that was run
178 $storage->dbh_do (sub { $_[1]->do($line) });
181 die "$_ (running line '$line')"
183 $storage->_query_end($line);
185 return join "\n", @$sql
188 method _run_sql($filename) {
189 log_debug { "[DBICDH] Running SQL from $filename" };
190 return $self->_run_sql_array($self->_read_sql_file($filename));
193 method _run_perl($filename) {
194 log_debug { "[DBICDH] Running Perl from $filename" };
195 my $filedata = do { local( @ARGV, $/ ) = $filename; <> };
197 no warnings 'redefine';
198 my $fn = eval "$filedata";
200 Dlog_trace { "[DBICDH] Running Perl $_" } $fn;
203 carp "$filename failed to compile: $@";
204 } elsif (ref $fn eq 'CODE') {
207 carp "$filename should define an anonymouse sub that takes a schema but it didn't!";
211 method _run_serialized_sql($filename, $type) {
212 if (lc $type eq 'json') {
213 return $self->_run_sql_array($self->_json->decode(
214 do { local( @ARGV, $/ ) = $filename; <> } # slurp
217 croak "$type is not one of the supported serialzed types"
221 method _run_sql_and_perl($filenames) {
222 my @files = @{$filenames};
223 my $guard = $self->schema->txn_scope_guard if $self->txn_wrap;
226 for my $filename (@files) {
227 if ($filename =~ /\.sql$/) {
228 $sql .= $self->_run_sql($filename)
229 } elsif ( $filename =~ /\.sql-(\w+)$/ ) {
230 $sql .= $self->_run_serialized_sql($filename, $1)
231 } elsif ( $filename =~ /\.pl$/ ) {
232 $self->_run_perl($filename)
234 croak "A file ($filename) got to deploy that wasn't sql or perl!";
238 $guard->commit if $self->txn_wrap;
245 my $version = (shift @_ || {})->{version} || $self->schema_version;
246 log_info { "[DBICDH] deploying version $version" };
248 return $self->_run_sql_and_perl($self->_ddl_schema_consume_filenames(
249 $self->storage->sqlt_type,
257 my $version = $args->{version} || $self->schema_version;
258 log_info { "[DBICDH] preinstalling version $version" };
259 my $storage_type = $args->{storage_type} || $self->storage->sqlt_type;
261 my @files = @{$self->_ddl_preinstall_consume_filenames(
266 for my $filename (@files) {
267 # We ignore sql for now (till I figure out what to do with it)
268 if ( $filename =~ /^(.+)\.pl$/ ) {
269 my $filedata = do { local( @ARGV, $/ ) = $filename; <> };
271 no warnings 'redefine';
272 my $fn = eval "$filedata";
276 carp "$filename failed to compile: $@";
277 } elsif (ref $fn eq 'CODE') {
280 carp "$filename should define an anonymous sub but it didn't!";
283 croak "A file ($filename) got to preinstall_scripts that wasn't sql or perl!";
288 sub _prepare_install {
290 my $sqltargs = { %{$self->sql_translator_args}, %{shift @_} };
292 my $schema = $self->schema;
293 my $databases = $self->databases;
294 my $dir = $self->script_directory;
295 my $version = $self->schema_version;
297 my $sqlt = SQL::Translator->new({
300 ignore_constraint_names => 1,
301 ignore_index_names => 1,
302 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 $filename = $self->$to_file($db, $version, $dir);
316 carp "Overwriting existing DDL file - $filename";
320 my $sql = $self->_generate_final_sql($sqlt);
322 carp("Failed to translate to $db, skipping. (" . $sqlt->error . ")");
325 open my $file, q(>), $filename;
331 method _generate_final_sql($sqlt) {
332 my @output = $sqlt->translate;
333 $self->_json->encode(\@output);
336 sub _resultsource_install_filename {
337 my ($self, $source_name) = @_;
339 my ($self, $type, $version) = @_;
340 my $dirname = catfile( $self->script_directory, $type, 'schema', $version );
341 mkpath($dirname) unless -d $dirname;
343 return catfile( $dirname, "001-auto-$source_name.sql-json" );
347 sub install_resultsource {
348 my ($self, $args) = @_;
349 my $source = $args->{result_source};
350 my $version = $args->{version};
351 log_info { '[DBICDH] installing_resultsource ' . $source->source_name . ", version $version" };
352 my $rs_install_file =
353 $self->_resultsource_install_filename($source->source_name);
356 $self->$rs_install_file(
357 $self->storage->sqlt_type,
361 $self->_run_sql_and_perl($files);
364 sub prepare_resultsource_install {
366 my $source = (shift @_)->{result_source};
367 log_info { '[DBICDH] preparing install for resultsource ' . $source->source_name };
369 my $filename = $self->_resultsource_install_filename($source->source_name);
370 $self->_prepare_install({
371 parser_args => { sources => [$source->source_name], }
376 log_info { '[DBICDH] preparing deploy' };
378 $self->_prepare_install({}, '_ddl_schema_produce_filename');
381 sub prepare_upgrade {
382 my ($self, $args) = @_;
384 '[DBICDH] preparing upgrade ' .
385 "from $args->{from_version} to $args->{to_version}"
387 $self->_prepare_changegrade(
388 $args->{from_version}, $args->{to_version}, $args->{version_set}, 'up'
392 sub prepare_downgrade {
393 my ($self, $args) = @_;
395 '[DBICDH] preparing downgrade ' .
396 "from $args->{from_version} to $args->{to_version}"
398 $self->_prepare_changegrade(
399 $args->{from_version}, $args->{to_version}, $args->{version_set}, 'down'
403 method _prepare_changegrade($from_version, $to_version, $version_set, $direction) {
404 my $schema = $self->schema;
405 my $databases = $self->databases;
406 my $dir = $self->script_directory;
407 my $sqltargs = $self->sql_translator_args;
409 my $schema_version = $self->schema_version;
414 ignore_constraint_names => 1,
415 ignore_index_names => 1,
419 my $sqlt = SQL::Translator->new( $sqltargs );
421 $sqlt->parser('SQL::Translator::Parser::DBIx::Class');
422 my $sqlt_schema = $sqlt->translate( data => $schema )
423 or croak($sqlt->error);
425 foreach my $db (@$databases) {
427 $sqlt->{schema} = $sqlt_schema;
428 $sqlt->producer($db);
430 my $prefilename = $self->_ddl_schema_produce_filename($db, $from_version, $dir);
431 unless(-e $prefilename) {
432 carp("No previous schema file found ($prefilename)");
435 my $diff_file_method = "_ddl_schema_${direction}_produce_filename";
436 my $diff_file = $self->$diff_file_method($db, $version_set, $dir );
438 carp("Overwriting existing $direction-diff file - $diff_file");
444 my $t = SQL::Translator->new({
450 $t->parser( $db ) # could this really throw an exception?
453 my $sql = $self->_default_read_sql_file_as_string($prefilename);
454 my $out = $t->translate( \$sql )
457 $source_schema = $t->schema;
459 $source_schema->name( $prefilename )
460 unless $source_schema->name;
463 # The "new" style of producers have sane normalization and can support
464 # diffing a SQL file against a DBIC->SQLT schema. Old style ones don't
465 # And we have to diff parsed SQL against parsed SQL.
466 my $dest_schema = $sqlt_schema;
468 unless ( "SQL::Translator::Producer::$db"->can('preprocess_schema') ) {
469 my $t = SQL::Translator->new({
475 $t->parser( $db ) # could this really throw an exception?
478 my $filename = $self->_ddl_schema_produce_filename($db, $to_version, $dir);
479 my $sql = $self->_default_read_sql_file_as_string($filename);
480 my $out = $t->translate( \$sql )
483 $dest_schema = $t->schema;
485 $dest_schema->name( $filename )
486 unless $dest_schema->name;
489 open my $file, q(>), $diff_file;
491 $self->_generate_final_diff($source_schema, $dest_schema, $db, $sqltargs);
496 method _generate_final_diff($source_schema, $dest_schema, $db, $sqltargs) {
497 $self->_json->encode([
498 SQL::Translator::Diff::schema_diff(
506 method _read_sql_file($file) {
509 open my $fh, '<', $file;
510 my @data = split /;\n/, join '', <$fh>;
516 method _default_read_sql_file_as_string($file) {
517 return join q(), map "$_;\n", @{$self->_json->decode(
518 do { local( @ARGV, $/ ) = $file; <> } # slurp
522 sub downgrade_single_step {
524 my $version_set = (shift @_)->{version_set};
525 Dlog_info { qq([DBICDH] downgrade_single_step'ing $_) } $version_set;
527 my $sql = $self->_run_sql_and_perl($self->_ddl_schema_down_consume_filenames(
528 $self->storage->sqlt_type,
535 sub upgrade_single_step {
537 my $version_set = (shift @_)->{version_set};
538 Dlog_info { qq([DBICDH] upgrade_single_step'ing $_) } $version_set;
540 my $sql = $self->_run_sql_and_perl($self->_ddl_schema_up_consume_filenames(
541 $self->storage->sqlt_type,
547 __PACKAGE__->meta->make_immutable;
551 # vim: ts=2 sw=2 expandtab
557 This class is the meat of L<DBIx::Class::DeploymentHandler>. It takes
558 care of generating serialized sql files representing schemata as well
559 as serialized sql files to move from one version of a schema to the rest.
560 One of the hallmark features of this class is that it allows for multiple sql
561 files for deploy and upgrade, allowing developers to fine tune deployment.
562 In addition it also allows for perl files to be run
563 at any stage of the process.
565 For basic usage see L<DBIx::Class::DeploymentHandler::HandlesDeploy>. What's
566 documented here is extra fun stuff or private methods.
568 =head1 DIRECTORY LAYOUT
570 Arguably this is the best feature of L<DBIx::Class::DeploymentHandler>. It's
571 heavily based upon L<DBIx::Migration::Directories>, but has some extensions and
572 modifications, so even if you are familiar with it, please read this. I feel
573 like the best way to describe the layout is with the following example:
579 | | `- 001-auto.sql-json
582 | | `- 001-auto.sql-json
585 | | `- 001-auto.sql-json
587 | `- 001-auto.sql-json
591 | | `- 002-remove-customers.pl
594 | `- 002-generate-customers.pl
598 | | `- 001-auto.sql-json
601 | | `- 001-auto.sql-json
604 | |- 001-auto.sql-json
605 | `- 002-create-stored-procedures.sql
609 | `- 001-auto.sql-json
612 | |- 001-create_database.pl
613 | `- 002-create_users_and_permissions.pl
616 | `- 001-auto.sql-json
621 So basically, the code
625 on an C<SQLite> database that would simply run
626 C<$sql_migration_dir/SQLite/schema/1/001-auto.sql-json>. Next,
628 $dm->upgrade_single_step([1,2])
630 would run C<$sql_migration_dir/SQLite/up/1-2/001-auto.sql-json> followed by
631 C<$sql_migration_dir/_common/up/1-2/002-generate-customers.pl>.
633 C<.pl> files don't have to be in the C<_common> directory, but most of the time
634 they should be, because perl scripts are generally be database independent.
636 C<_generic> exists for when you for some reason are sure that your SQL is
637 generic enough to run on all databases. Good luck with that one.
639 Note that unlike most steps in the process, C<preinstall> will not run SQL, as
640 there may not even be an database at preinstall time. It will run perl scripts
641 just like the other steps in the process, but nothing is passed to them.
642 Until people have used this more it will remain freeform, but a recommended use
643 of preinstall is to have it prompt for username and password, and then call the
644 appropriate C<< CREATE DATABASE >> commands etc.
646 =head1 SERIALIZED SQL
648 The SQL that this module generates and uses is serialized into an array of
649 SQL statements. The reason being that some databases handle multiple
650 statements in a single execution differently. Generally you do not need to
651 worry about this as these are scripts generated for you. If you find that
652 you are editing them on a regular basis something is wrong and you either need
653 to submit a bug or consider writing extra serialized SQL or Perl scripts to run
654 before or after the automatically generated script.
656 B<NOTE:> Currently the SQL is serialized into JSON. I am willing to merge in
657 patches that will allow more serialization formats if you want that feature,
658 but if you do send me a patch for that realize that I do not want to add YAML
659 support or whatever, I would rather add a generic method of adding any
660 serialization format.
664 A perl script for this tool is very simple. It merely needs to contain an
665 anonymous sub that takes a L<DBIx::Class::Schema> as it's only argument.
666 A very basic perl script might look like:
676 $schema->resultset('Users')->create({
684 The L<DBIx::Class::Schema> (B<required>) that is used to talk to the database
685 and generate the DDL.
689 The L<DBIx::Class::Storage> that is I<actually> used to talk to the database
690 and generate the DDL. This is automatically created with L</_build_storage>.
692 =attr sql_translator_args
694 The arguments that get passed to L<SQL::Translator> when it's used.
696 =attr script_directory
698 The directory (default C<'sql'>) that scripts are stored in
702 The types of databases (default C<< [qw( MySQL SQLite PostgreSQL )] >>) to
707 Set to true (which is the default) to wrap all upgrades and deploys in a single
712 The version the schema on your harddrive is at. Defaults to
713 C<< $self->schema->schema_version >>.
717 =head2 __ddl_consume_with_prefix
719 $dm->__ddl_consume_with_prefix( 'SQLite', [qw( 1.00 1.01 )], 'up' )
721 This is the meat of the multi-file upgrade/deploy stuff. It returns a list of
722 files in the order that they should be run for a generic "type" of upgrade.
723 You should not be calling this in user code.
725 =head2 _ddl_schema_consume_filenames
727 $dm->__ddl_schema_consume_filenames( 'SQLite', [qw( 1.00 )] )
729 Just a curried L</__ddl_consume_with_prefix>. Get's a list of files for an
732 =head2 _ddl_schema_produce_filename
734 $dm->__ddl_schema_produce_filename( 'SQLite', [qw( 1.00 )] )
736 Returns a single file in which an initial schema will be stored.
738 =head2 _ddl_schema_up_consume_filenames
740 $dm->_ddl_schema_up_consume_filenames( 'SQLite', [qw( 1.00 )] )
742 Just a curried L</__ddl_consume_with_prefix>. Get's a list of files for an
745 =head2 _ddl_schema_down_consume_filenames
747 $dm->_ddl_schema_down_consume_filenames( 'SQLite', [qw( 1.00 )] )
749 Just a curried L</__ddl_consume_with_prefix>. Get's a list of files for a
752 =head2 _ddl_schema_up_produce_filenames
754 $dm->_ddl_schema_up_produce_filename( 'SQLite', [qw( 1.00 1.01 )] )
756 Returns a single file in which the sql to upgrade from one schema to another
759 =head2 _ddl_schema_down_produce_filename
761 $dm->_ddl_schema_down_produce_filename( 'SQLite', [qw( 1.00 1.01 )] )
763 Returns a single file in which the sql to downgrade from one schema to another
766 =head2 _resultsource_install_filename
768 my $filename_fn = $dm->_resultsource_install_filename('User');
769 $dm->$filename_fn('SQLite', '1.00')
771 Returns a function which in turn returns a single filename used to install a
772 single resultsource. Weird interface is convenient for me. Deal with it.
774 =head2 _run_sql_and_perl
776 $dm->_run_sql_and_perl([qw( list of filenames )])
778 Simply put, this runs the list of files passed to it. If the file ends in
779 C<.sql> it runs it as sql and if it ends in C<.pl> it runs it as a perl file.
781 Depending on L</txn_wrap> all of the files run will be wrapped in a single
784 =head2 _prepare_install
786 $dm->_prepare_install({ add_drop_table => 0 }, sub { 'file_to_create' })
788 Generates the sql file for installing the database. First arg is simply
789 L<SQL::Translator> args and the second is a coderef that returns the filename
792 =head2 _prepare_changegrade
794 $dm->_prepare_changegrade('1.00', '1.01', [qw( 1.00 1.01)], 'up')
796 Generates the sql file for migrating from one schema version to another. First
797 arg is the version to start from, second is the version to go to, third is the
798 L<version set|DBIx::Class::DeploymentHandler/VERSION SET>, and last is the
799 direction of the changegrade, be it 'up' or 'down'.
801 =head2 _read_sql_file
803 $dm->_read_sql_file('foo.sql')
805 Reads a sql file and returns lines in an C<ArrayRef>. Strips out comments,
806 transactions, and blank lines.