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), -package_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';
35 isa => 'DBIx::Class::Schema',
41 isa => 'DBIx::Class::Storage',
46 method _build_storage {
47 my $s = $self->schema->storage;
48 $s->_determine_driver;
52 has sql_translator_args => (
55 default => sub { {} },
57 has script_directory => (
66 isa => 'DBIx::Class::DeploymentHandler::Databases',
68 default => sub { [qw( MySQL SQLite PostgreSQL )] },
77 has schema_version => (
83 # this will probably never get called as the DBICDH
84 # will be passing down a schema_version normally, which
85 # is built the same way, but we leave this in place
86 method _build_schema_version { $self->schema->schema_version }
88 method __ddl_consume_with_prefix($type, $versions, $prefix) {
89 my $base_dir = $self->script_directory;
91 my $main = catfile( $base_dir, $type );
93 catfile( $base_dir, '_common', $prefix, join q(-), @{$versions} );
97 $dir = catfile($main, $prefix, join q(-), @{$versions})
99 if ($self->ignore_ddl) {
102 croak "$main does not exist; please write/generate some SQL"
108 opendir my($dh), $dir;
110 map { $_ => "$dir/$_" }
111 grep { /\.(?:sql|pl|sql-\w+)$/ && -f "$dir/$_" }
115 die $_ unless $self->ignore_ddl;
118 opendir my($dh), $common;
119 for my $filename (grep { /\.(?:sql|pl)$/ && -f catfile($common,$_) } readdir $dh) {
120 unless ($files{$filename}) {
121 $files{$filename} = catfile($common,$filename);
127 return [@files{sort keys %files}]
130 method _ddl_initialize_consume_filenames($type, $version) {
131 $self->__ddl_consume_with_prefix($type, [ $version ], 'initialize')
134 method _ddl_schema_consume_filenames($type, $version) {
135 $self->__ddl_consume_with_prefix($type, [ $version ], 'deploy')
138 method _ddl_protoschema_deploy_consume_filenames($version) {
139 my $base_dir = $self->script_directory;
141 my $dir = catfile( $base_dir, '_source', 'deploy', $version);
142 return [] unless -d $dir;
144 opendir my($dh), $dir;
145 my %files = map { $_ => "$dir/$_" } grep { /\.yml$/ && -f "$dir/$_" } readdir $dh;
148 return [@files{sort keys %files}]
151 method _ddl_protoschema_upgrade_consume_filenames($versions) {
152 my $base_dir = $self->script_directory;
154 my $dir = catfile( $base_dir, '_preprocess_schema', 'upgrade', join q(-), @{$versions});
156 return [] unless -d $dir;
158 opendir my($dh), $dir;
159 my %files = map { $_ => "$dir/$_" } grep { /\.pl$/ && -f "$dir/$_" } readdir $dh;
162 return [@files{sort keys %files}]
165 method _ddl_protoschema_downgrade_consume_filenames($versions) {
166 my $base_dir = $self->script_directory;
168 my $dir = catfile( $base_dir, '_preprocess_schema', 'downgrade', join q(-), @{$versions});
170 return [] unless -d $dir;
172 opendir my($dh), $dir;
173 my %files = map { $_ => "$dir/$_" } grep { /\.pl$/ && -f "$dir/$_" } readdir $dh;
176 return [@files{sort keys %files}]
179 method _ddl_protoschema_produce_filename($version) {
180 my $dirname = catfile( $self->script_directory, '_source', 'deploy', $version );
181 mkpath($dirname) unless -d $dirname;
183 return catfile( $dirname, '001-auto.yml' );
186 method _ddl_schema_produce_filename($type, $version) {
187 my $dirname = catfile( $self->script_directory, $type, 'deploy', $version );
188 mkpath($dirname) unless -d $dirname;
190 return catfile( $dirname, '001-auto.sql' );
193 method _ddl_schema_upgrade_consume_filenames($type, $versions) {
194 $self->__ddl_consume_with_prefix($type, $versions, 'upgrade')
197 method _ddl_schema_downgrade_consume_filenames($type, $versions) {
198 $self->__ddl_consume_with_prefix($type, $versions, 'downgrade')
201 method _ddl_schema_upgrade_produce_filename($type, $versions) {
202 my $dir = $self->script_directory;
204 my $dirname = catfile( $dir, $type, 'upgrade', join q(-), @{$versions});
205 mkpath($dirname) unless -d $dirname;
207 return catfile( $dirname, '001-auto.sql' );
210 method _ddl_schema_downgrade_produce_filename($type, $versions, $dir) {
211 my $dirname = catfile( $dir, $type, 'downgrade', join q(-), @{$versions} );
212 mkpath($dirname) unless -d $dirname;
214 return catfile( $dirname, '001-auto.sql');
217 method _run_sql_array($sql) {
218 my $storage = $self->storage;
221 $_ && # remove blank lines
222 !/^(BEGIN|BEGIN TRANSACTION|COMMIT)/ # strip txn's
224 s/^\s+//; s/\s+$//; # trim whitespace
225 join '', grep { !/^--/ } split /\n/ # remove comments
228 Dlog_trace { "Running SQL $_" } $sql;
229 foreach my $line (@{$sql}) {
230 $storage->_query_start($line);
231 # the whole reason we do this is so that we can see the line that was run
233 $storage->dbh_do (sub { $_[1]->do($line) });
236 die "$_ (running line '$line')"
238 $storage->_query_end($line);
240 return join "\n", @$sql
243 method _run_sql($filename) {
244 log_debug { "Running SQL from $filename" };
245 return $self->_run_sql_array($self->_read_sql_file($filename));
248 method _run_perl($filename) {
249 log_debug { "Running Perl from $filename" };
250 my $filedata = do { local( @ARGV, $/ ) = $filename; <> };
252 no warnings 'redefine';
253 my $fn = eval "$filedata";
255 Dlog_trace { "Running Perl $_" } $fn;
258 carp "$filename failed to compile: $@";
259 } elsif (ref $fn eq 'CODE') {
262 carp "$filename should define an anonymouse sub that takes a schema but it didn't!";
266 method _run_sql_and_perl($filenames, $sql_to_run) {
267 my @files = @{$filenames};
268 my $guard = $self->schema->txn_scope_guard if $self->txn_wrap;
270 $self->_run_sql_array($sql_to_run) if $self->ignore_ddl;
272 my $sql = ($sql_to_run)?join ";\n", @$sql_to_run:'';
274 for my $filename (@files) {
275 if ($self->ignore_ddl && $filename =~ /^[^_]*-auto.*\.sql$/) {
277 } elsif ($filename =~ /\.sql$/) {
278 $sql .= $self->_run_sql($filename)
279 } elsif ( $filename =~ /\.pl$/ ) {
280 $self->_run_perl($filename)
282 croak "A file ($filename) got to deploy that wasn't sql or perl!";
286 $guard->commit if $self->txn_wrap;
293 my $version = (shift @_ || {})->{version} || $self->schema_version;
294 log_info { "deploying version $version" };
295 my $sqlt_type = $self->storage->sqlt_type;
297 if ($self->ignore_ddl) {
298 $sql = $self->_sql_from_yaml({},
299 '_ddl_protoschema_produce_filename', $sqlt_type
302 return $self->_run_sql_and_perl($self->_ddl_schema_consume_filenames(
311 my $version = $args->{version} || $self->schema_version;
312 log_info { "initializing version $version" };
313 my $storage_type = $args->{storage_type} || $self->storage->sqlt_type;
315 my @files = @{$self->_ddl_initialize_consume_filenames(
320 for my $filename (@files) {
321 # We ignore sql for now (till I figure out what to do with it)
322 if ( $filename =~ /^(.+)\.pl$/ ) {
323 my $filedata = do { local( @ARGV, $/ ) = $filename; <> };
325 no warnings 'redefine';
326 my $fn = eval "$filedata";
330 carp "$filename failed to compile: $@";
331 } elsif (ref $fn eq 'CODE') {
334 carp "$filename should define an anonymous sub but it didn't!";
337 croak "A file ($filename) got to initialize_scripts that wasn't sql or perl!";
342 method _sqldiff_from_yaml($from_version, $to_version, $db, $direction) {
343 my $dir = $self->script_directory;
346 ignore_constraint_names => 1,
347 ignore_index_names => 1,
348 %{$self->sql_translator_args}
353 my $prefilename = $self->_ddl_protoschema_produce_filename($from_version, $dir);
355 # should probably be a croak
356 carp("No previous schema file found ($prefilename)")
357 unless -e $prefilename;
359 my $t = SQL::Translator->new({
363 parser => 'SQL::Translator::Parser::YAML',
366 my $out = $t->translate( $prefilename )
369 $source_schema = $t->schema;
371 $source_schema->name( $prefilename )
372 unless $source_schema->name;
377 my $filename = $self->_ddl_protoschema_produce_filename($to_version, $dir);
379 # should probably be a croak
380 carp("No next schema file found ($filename)")
383 my $t = SQL::Translator->new({
387 parser => 'SQL::Translator::Parser::YAML',
390 my $out = $t->translate( $filename )
393 $dest_schema = $t->schema;
395 $dest_schema->name( $filename )
396 unless $dest_schema->name;
399 my $transform_files_method = "_ddl_protoschema_${direction}_consume_filenames";
400 my $transforms = $self->_coderefs_per_files(
401 $self->$transform_files_method([$from_version, $to_version])
403 $_->($source_schema, $dest_schema) for @$transforms;
405 return [SQL::Translator::Diff::schema_diff(
412 method _sql_from_yaml($sqltargs, $from_file, $db) {
413 my $schema = $self->schema;
414 my $version = $self->schema_version;
416 my $sqlt = SQL::Translator->new({
418 parser => 'SQL::Translator::Parser::YAML',
423 my $yaml_filename = $self->$from_file($version);
425 my @sql = $sqlt->translate($yaml_filename);
427 carp("Failed to translate to $db, skipping. (" . $sqlt->error . ")");
433 sub _prepare_install {
435 my $sqltargs = { %{$self->sql_translator_args}, %{shift @_} };
436 my $from_file = shift;
438 my $dir = $self->script_directory;
439 my $databases = $self->databases;
440 my $version = $self->schema_version;
442 foreach my $db (@$databases) {
443 my $sql = $self->_sql_from_yaml($sqltargs, $from_file, $db ) or next;
445 my $filename = $self->$to_file($db, $version, $dir);
447 carp "Overwriting existing DDL file - $filename";
450 open my $file, q(>), $filename;
451 print {$file} join ";\n", @$sql;
456 sub _resultsource_install_filename {
457 my ($self, $source_name) = @_;
459 my ($self, $type, $version) = @_;
460 my $dirname = catfile( $self->script_directory, $type, 'deploy', $version );
461 mkpath($dirname) unless -d $dirname;
463 return catfile( $dirname, "001-auto-$source_name.sql" );
467 sub _resultsource_protoschema_filename {
468 my ($self, $source_name) = @_;
470 my ($self, $version) = @_;
471 my $dirname = catfile( $self->script_directory, '_source', 'deploy', $version );
472 mkpath($dirname) unless -d $dirname;
474 return catfile( $dirname, "001-auto-$source_name.yml" );
478 sub install_resultsource {
479 my ($self, $args) = @_;
480 my $source = $args->{result_source};
481 my $version = $args->{version};
482 log_info { 'installing_resultsource ' . $source->source_name . ", version $version" };
483 my $rs_install_file =
484 $self->_resultsource_install_filename($source->source_name);
487 $self->$rs_install_file(
488 $self->storage->sqlt_type,
492 $self->_run_sql_and_perl($files);
495 sub prepare_resultsource_install {
497 my $source = (shift @_)->{result_source};
498 log_info { 'preparing install for resultsource ' . $source->source_name };
500 my $install_filename = $self->_resultsource_install_filename($source->source_name);
501 my $proto_filename = $self->_resultsource_protoschema_filename($source->source_name);
502 $self->prepare_protoschema({
503 parser_args => { sources => [$source->source_name], }
505 $self->_prepare_install({}, $proto_filename, $install_filename);
509 log_info { 'preparing deploy' };
511 $self->prepare_protoschema({
512 # Exclude __VERSION so that it gets installed separately
513 parser_args => { sources => [grep { $_ ne '__VERSION' } $self->schema->sources], }
514 }, '_ddl_protoschema_produce_filename');
515 $self->_prepare_install({}, '_ddl_protoschema_produce_filename', '_ddl_schema_produce_filename');
518 sub prepare_upgrade {
519 my ($self, $args) = @_;
521 "preparing upgrade from $args->{from_version} to $args->{to_version}"
523 $self->_prepare_changegrade(
524 $args->{from_version}, $args->{to_version}, $args->{version_set}, 'upgrade'
528 sub prepare_downgrade {
529 my ($self, $args) = @_;
531 "preparing downgrade from $args->{from_version} to $args->{to_version}"
533 $self->_prepare_changegrade(
534 $args->{from_version}, $args->{to_version}, $args->{version_set}, 'downgrade'
538 method _coderefs_per_files($files) {
539 no warnings 'redefine';
540 [map eval do { local( @ARGV, $/ ) = $_; <> }, @$files]
543 method _prepare_changegrade($from_version, $to_version, $version_set, $direction) {
544 my $schema = $self->schema;
545 my $databases = $self->databases;
546 my $dir = $self->script_directory;
548 my $schema_version = $self->schema_version;
549 my $diff_file_method = "_ddl_schema_${direction}_produce_filename";
550 foreach my $db (@$databases) {
551 my $diff_file = $self->$diff_file_method($db, $version_set, $dir );
553 carp("Overwriting existing $direction-diff file - $diff_file");
557 open my $file, q(>), $diff_file;
558 print {$file} join ";\n", @{$self->_sqldiff_from_yaml($from_version, $to_version, $db, $direction)};
563 method _read_sql_file($file) {
566 open my $fh, '<', $file;
567 my @data = split /;\n/, join '', <$fh>;
571 $_ && # remove blank lines
572 !/^(BEGIN|BEGIN TRANSACTION|COMMIT)/ # strip txn's
574 s/^\s+//; s/\s+$//; # trim whitespace
575 join '', grep { !/^--/ } split /\n/ # remove comments
581 sub downgrade_single_step {
583 my $version_set = (shift @_)->{version_set};
584 Dlog_info { "downgrade_single_step'ing $_" } $version_set;
586 my $sqlt_type = $self->storage->sqlt_type;
588 if ($self->ignore_ddl) {
589 $sql_to_run = $self->_sqldiff_from_yaml(
590 $version_set->[0], $version_set->[1], $sqlt_type, 'downgrade',
593 my $sql = $self->_run_sql_and_perl($self->_ddl_schema_downgrade_consume_filenames(
601 sub upgrade_single_step {
603 my $version_set = (shift @_)->{version_set};
604 Dlog_info { "upgrade_single_step'ing $_" } $version_set;
606 my $sqlt_type = $self->storage->sqlt_type;
608 if ($self->ignore_ddl) {
609 $sql_to_run = $self->_sqldiff_from_yaml(
610 $version_set->[0], $version_set->[1], $sqlt_type, 'upgrade',
613 my $sql = $self->_run_sql_and_perl($self->_ddl_schema_upgrade_consume_filenames(
620 sub prepare_protoschema {
622 my $sqltargs = { %{$self->sql_translator_args}, %{shift @_} };
625 = $self->$to_file($self->schema_version);
627 # we do this because the code that uses this sets parser args,
628 # so we just need to merge in the package
629 $sqltargs->{parser_args}{package} = $self->schema;
630 my $sqlt = SQL::Translator->new({
631 parser => 'SQL::Translator::Parser::DBIx::Class',
632 producer => 'SQL::Translator::Producer::YAML',
636 my $yml = $sqlt->translate;
638 croak("Failed to translate to YAML: " . $sqlt->error)
642 carp "Overwriting existing DDL-YML file - $filename";
646 open my $file, q(>), $filename;
651 __PACKAGE__->meta->make_immutable;
655 # vim: ts=2 sw=2 expandtab
661 This class is the meat of L<DBIx::Class::DeploymentHandler>. It takes care
662 of generating serialized schemata as well as sql files to move from one
663 version of a schema to the rest. One of the hallmark features of this class
664 is that it allows for multiple sql files for deploy and upgrade, allowing
665 developers to fine tune deployment. In addition it also allows for perl
666 files to be run at any stage of the process.
668 For basic usage see L<DBIx::Class::DeploymentHandler::HandlesDeploy>. What's
669 documented here is extra fun stuff or private methods.
671 =head1 DIRECTORY LAYOUT
673 Arguably this is the best feature of L<DBIx::Class::DeploymentHandler>.
674 It's spiritually based upon L<DBIx::Migration::Directories>, but has a
675 lot of extensions and modifications, so even if you are familiar with it,
676 please read this. I feel like the best way to describe the layout is with
677 the following example:
703 | | `- 002-remove-customers.pl
706 | `- 002-generate-customers.pl
713 | |- 001-create_database.pl
714 | `- 002-create_users_and_permissions.pl
722 So basically, the code
726 on an C<SQLite> database that would simply run
727 C<$sql_migration_dir/SQLite/deploy/1/001-auto.sql>. Next,
729 $dm->upgrade_single_step([1,2])
731 would run C<$sql_migration_dir/SQLite/upgrade/1-2/001-auto.sql> followed by
732 C<$sql_migration_dir/_common/upgrade/1-2/002-generate-customers.pl>.
734 C<.pl> files don't have to be in the C<_common> directory, but most of the time
735 they should be, because perl scripts are generally database independent.
737 Note that unlike most steps in the process, C<initialize> will not run SQL, as
738 there may not even be an database at initialize time. It will run perl scripts
739 just like the other steps in the process, but nothing is passed to them.
740 Until people have used this more it will remain freeform, but a recommended use
741 of initialize is to have it prompt for username and password, and then call the
742 appropriate C<< CREATE DATABASE >> commands etc.
744 =head2 Directory Specification
746 The following subdirectories are recognized by this DeployMethod:
750 =item C<_source> This directory can contain the following directories:
754 =item C<deploy> This directory merely contains directories named after schema
755 versions, which in turn contain C<yaml> files that are serialized versions
756 of the schema at that version. These files are not for editing by hand.
760 =item C<_preprocess_schema> This directory can contain the following
765 =item C<downgrade> This directory merely contains directories named after
766 migrations, which are of the form C<$from_version-$to_version>. Inside of
767 these directories you may put Perl scripts which are to return a subref
768 that takes the arguments C<< $from_schema, $to_schema >>, which are
769 L<SQL::Translator::Schema> objects.
771 =item C<upgrade> This directory merely contains directories named after
772 migrations, which are of the form C<$from_version-$to_version>. Inside of
773 these directories you may put Perl scripts which are to return a subref
774 that takes the arguments C<< $from_schema, $to_schema >>, which are
775 L<SQL::Translator::Schema> objects.
779 =item C<$storage_type> This is a set of scripts that gets run depending on what
780 your storage type is. If you are not sure what your storage type is, take a
781 look at the producers listed for L<SQL::Translator>. Also note, C<_common>
782 is a special case. C<_common> will get merged into whatever other files you
783 already have. This directory can containt the following directories itself:
787 =item C<initialize> Gets run before the C<deploy> is C<deploy>ed. Has the
788 same structure as the C<deploy> subdirectory as well; that is, it has a
789 directory for each schema version. Unlike C<deploy>, C<upgrade>, and C<downgrade>
790 though, it can only run C<.pl> files, and the coderef in the perl files get
791 no arguments passed to them.
793 =item C<deploy> Gets run when the schema is C<deploy>ed. Structure is a
794 directory per schema version, and then files are merged with C<_common> and run
795 in filename order. C<.sql> files are merely run, as expected. C<.pl> files are
796 run according to L</PERL SCRIPTS>.
798 =item C<upgrade> Gets run when the schema is C<upgrade>d. Structure is a directory
799 per upgrade step, (for example, C<1-2> for upgrading from version 1 to version
800 2,) and then files are merged with C<_common> and run in filename order.
801 C<.sql> files are merely run, as expected. C<.pl> files are run according
804 =item C<downgrade> Gets run when the schema is C<downgrade>d. Structure is a directory
805 per downgrade step, (for example, C<2-1> for downgrading from version 2 to version
806 1,) and then files are merged with C<_common> and run in filename order.
807 C<.sql> files are merely run, as expected. C<.pl> files are run according
817 A perl script for this tool is very simple. It merely needs to contain an
818 anonymous sub that takes a L<DBIx::Class::Schema> as it's only argument.
819 A very basic perl script might look like:
829 $schema->resultset('Users')->create({
837 This attribute will, when set to true (default is false), cause the DM to use
838 L<SQL::Translator> to use the C<_source>'s serialized SQL::Translator::Schema
839 instead of any pregenerated SQL. If you have a development server this is
840 probably the best plan of action as you will not be putting as many generated
841 files in your version control. Goes well with with C<databases> of C<[]>.
845 The L<DBIx::Class::Schema> (B<required>) that is used to talk to the database
846 and generate the DDL.
850 The L<DBIx::Class::Storage> that is I<actually> used to talk to the database
851 and generate the DDL. This is automatically created with L</_build_storage>.
853 =attr sql_translator_args
855 The arguments that get passed to L<SQL::Translator> when it's used.
857 =attr script_directory
859 The directory (default C<'sql'>) that scripts are stored in
863 The types of databases (default C<< [qw( MySQL SQLite PostgreSQL )] >>) to
868 Set to true (which is the default) to wrap all upgrades and deploys in a single
873 The version the schema on your harddrive is at. Defaults to
874 C<< $self->schema->schema_version >>.