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';
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 croak "$main does not exist; please write/generate some SQL";
104 opendir my($dh), $dir;
106 map { $_ => "$dir/$_" }
107 grep { /\.(?:sql|pl|sql-\w+)$/ && -f "$dir/$_" }
111 die $_ unless $self->ignore_ddl;
114 opendir my($dh), $common;
115 for my $filename (grep { /\.(?:sql|pl)$/ && -f catfile($common,$_) } readdir $dh) {
116 unless ($files{$filename}) {
117 $files{$filename} = catfile($common,$filename);
123 return [@files{sort keys %files}]
126 method _ddl_preinstall_consume_filenames($type, $version) {
127 $self->__ddl_consume_with_prefix($type, [ $version ], 'preinstall')
130 method _ddl_schema_consume_filenames($type, $version) {
131 $self->__ddl_consume_with_prefix($type, [ $version ], 'deploy')
134 method _ddl_protoschema_upgrade_consume_filenames($versions) {
135 my $base_dir = $self->script_directory;
137 my $dir = catfile( $base_dir, '_preprocess_schema', 'upgrade', join q(-), @{$versions});
139 return [] unless -d $dir;
141 opendir my($dh), $dir;
142 my %files = map { $_ => "$dir/$_" } grep { /\.pl$/ && -f "$dir/$_" } readdir $dh;
145 return [@files{sort keys %files}]
148 method _ddl_protoschema_downgrade_consume_filenames($versions) {
149 my $base_dir = $self->script_directory;
151 my $dir = catfile( $base_dir, '_preprocess_schema', 'downgrade', join q(-), @{$versions});
153 return [] unless -d $dir;
155 opendir my($dh), $dir;
156 my %files = map { $_ => "$dir/$_" } grep { /\.pl$/ && -f "$dir/$_" } readdir $dh;
159 return [@files{sort keys %files}]
162 method _ddl_protoschema_produce_filename($version) {
163 my $dirname = catfile( $self->script_directory, '_source', 'deploy', $version );
164 mkpath($dirname) unless -d $dirname;
166 return catfile( $dirname, '001-auto.yml' );
169 method _ddl_schema_produce_filename($type, $version) {
170 my $dirname = catfile( $self->script_directory, $type, 'deploy', $version );
171 mkpath($dirname) unless -d $dirname;
173 return catfile( $dirname, '001-auto.sql' );
176 method _ddl_schema_upgrade_consume_filenames($type, $versions) {
177 $self->__ddl_consume_with_prefix($type, $versions, 'upgrade')
180 method _ddl_schema_downgrade_consume_filenames($type, $versions) {
181 $self->__ddl_consume_with_prefix($type, $versions, 'downgrade')
184 method _ddl_schema_upgrade_produce_filename($type, $versions) {
185 my $dir = $self->script_directory;
187 my $dirname = catfile( $dir, $type, 'upgrade', join q(-), @{$versions});
188 mkpath($dirname) unless -d $dirname;
190 return catfile( $dirname, '001-auto.sql' );
193 method _ddl_schema_downgrade_produce_filename($type, $versions, $dir) {
194 my $dirname = catfile( $dir, $type, 'downgrade', join q(-), @{$versions} );
195 mkpath($dirname) unless -d $dirname;
197 return catfile( $dirname, '001-auto.sql');
200 method _run_sql_array($sql) {
201 my $storage = $self->storage;
204 $_ && # remove blank lines
205 !/^(BEGIN|BEGIN TRANSACTION|COMMIT)/ # strip txn's
207 s/^\s+//; s/\s+$//; # trim whitespace
208 join '', grep { !/^--/ } split /\n/ # remove comments
211 Dlog_trace { "Running SQL $_" } $sql;
212 foreach my $line (@{$sql}) {
213 $storage->_query_start($line);
214 # the whole reason we do this is so that we can see the line that was run
216 $storage->dbh_do (sub { $_[1]->do($line) });
219 die "$_ (running line '$line')"
221 $storage->_query_end($line);
223 return join "\n", @$sql
226 method _run_sql($filename) {
227 log_debug { "Running SQL from $filename" };
228 return $self->_run_sql_array($self->_read_sql_file($filename));
231 method _run_perl($filename) {
232 log_debug { "Running Perl from $filename" };
233 my $filedata = do { local( @ARGV, $/ ) = $filename; <> };
235 no warnings 'redefine';
236 my $fn = eval "$filedata";
238 Dlog_trace { "Running Perl $_" } $fn;
241 carp "$filename failed to compile: $@";
242 } elsif (ref $fn eq 'CODE') {
245 carp "$filename should define an anonymouse sub that takes a schema but it didn't!";
249 method _run_sql_and_perl($filenames, $sql_to_run) {
250 my @files = @{$filenames};
251 my $guard = $self->schema->txn_scope_guard if $self->txn_wrap;
253 $self->_run_sql_array($sql_to_run) if $self->ignore_ddl;
255 my $sql = ($sql_to_run)?join ";\n", @$sql_to_run:'';
257 for my $filename (@files) {
258 if ($self->ignore_ddl && $filename =~ /^[^_]*-auto.*\.sql$/) {
260 } elsif ($filename =~ /\.sql$/) {
261 $sql .= $self->_run_sql($filename)
262 } elsif ( $filename =~ /\.pl$/ ) {
263 $self->_run_perl($filename)
265 croak "A file ($filename) got to deploy that wasn't sql or perl!";
269 $guard->commit if $self->txn_wrap;
276 my $version = (shift @_ || {})->{version} || $self->schema_version;
277 log_info { "deploying version $version" };
278 my $sqlt_type = $self->storage->sqlt_type;
280 if ($self->ignore_ddl) {
281 $sql = $self->_sql_from_yaml({},
282 '_ddl_protoschema_produce_filename', $sqlt_type
285 return $self->_run_sql_and_perl($self->_ddl_schema_consume_filenames(
294 my $version = $args->{version} || $self->schema_version;
295 log_info { "preinstalling version $version" };
296 my $storage_type = $args->{storage_type} || $self->storage->sqlt_type;
298 my @files = @{$self->_ddl_preinstall_consume_filenames(
303 for my $filename (@files) {
304 # We ignore sql for now (till I figure out what to do with it)
305 if ( $filename =~ /^(.+)\.pl$/ ) {
306 my $filedata = do { local( @ARGV, $/ ) = $filename; <> };
308 no warnings 'redefine';
309 my $fn = eval "$filedata";
313 carp "$filename failed to compile: $@";
314 } elsif (ref $fn eq 'CODE') {
317 carp "$filename should define an anonymous sub but it didn't!";
320 croak "A file ($filename) got to preinstall_scripts that wasn't sql or perl!";
325 method _sqldiff_from_yaml($from_version, $to_version, $db, $direction) {
326 my $dir = $self->script_directory;
329 ignore_constraint_names => 1,
330 ignore_index_names => 1,
331 %{$self->sql_translator_args}
336 my $prefilename = $self->_ddl_protoschema_produce_filename($from_version, $dir);
338 # should probably be a croak
339 carp("No previous schema file found ($prefilename)")
340 unless -e $prefilename;
342 my $t = SQL::Translator->new({
346 parser => 'SQL::Translator::Parser::YAML',
349 my $out = $t->translate( $prefilename )
352 $source_schema = $t->schema;
354 $source_schema->name( $prefilename )
355 unless $source_schema->name;
360 my $filename = $self->_ddl_protoschema_produce_filename($to_version, $dir);
362 # should probably be a croak
363 carp("No next schema file found ($filename)")
366 my $t = SQL::Translator->new({
370 parser => 'SQL::Translator::Parser::YAML',
373 my $out = $t->translate( $filename )
376 $dest_schema = $t->schema;
378 $dest_schema->name( $filename )
379 unless $dest_schema->name;
382 my $transform_files_method = "_ddl_protoschema_${direction}_consume_filenames";
383 my $transforms = $self->_coderefs_per_files(
384 $self->$transform_files_method([$from_version, $to_version])
386 $_->($source_schema, $dest_schema) for @$transforms;
388 return [SQL::Translator::Diff::schema_diff(
395 method _sql_from_yaml($sqltargs, $from_file, $db) {
396 my $schema = $self->schema;
397 my $version = $self->schema_version;
399 my $sqlt = SQL::Translator->new({
401 parser => 'SQL::Translator::Parser::YAML',
406 my $yaml_filename = $self->$from_file($version);
408 my @sql = $sqlt->translate($yaml_filename);
410 carp("Failed to translate to $db, skipping. (" . $sqlt->error . ")");
416 sub _prepare_install {
418 my $sqltargs = { %{$self->sql_translator_args}, %{shift @_} };
419 my $from_file = shift;
421 my $dir = $self->script_directory;
422 my $databases = $self->databases;
423 my $version = $self->schema_version;
425 foreach my $db (@$databases) {
426 my $sql = $self->_sql_from_yaml($sqltargs, $from_file, $db ) or next;
428 my $filename = $self->$to_file($db, $version, $dir);
430 carp "Overwriting existing DDL file - $filename";
433 open my $file, q(>), $filename;
434 print {$file} join ";\n", @$sql;
439 sub _resultsource_install_filename {
440 my ($self, $source_name) = @_;
442 my ($self, $type, $version) = @_;
443 my $dirname = catfile( $self->script_directory, $type, 'deploy', $version );
444 mkpath($dirname) unless -d $dirname;
446 return catfile( $dirname, "001-auto-$source_name.sql" );
450 sub _resultsource_protoschema_filename {
451 my ($self, $source_name) = @_;
453 my ($self, $version) = @_;
454 my $dirname = catfile( $self->script_directory, '_source', $version );
455 mkpath($dirname) unless -d $dirname;
457 return catfile( $dirname, "001-auto-$source_name.yml" );
461 sub install_resultsource {
462 my ($self, $args) = @_;
463 my $source = $args->{result_source};
464 my $version = $args->{version};
465 log_info { 'installing_resultsource ' . $source->source_name . ", version $version" };
466 my $rs_install_file =
467 $self->_resultsource_install_filename($source->source_name);
470 $self->$rs_install_file(
471 $self->storage->sqlt_type,
475 $self->_run_sql_and_perl($files);
478 sub prepare_resultsource_install {
480 my $source = (shift @_)->{result_source};
481 log_info { 'preparing install for resultsource ' . $source->source_name };
483 my $install_filename = $self->_resultsource_install_filename($source->source_name);
484 my $proto_filename = $self->_resultsource_protoschema_filename($source->source_name);
485 $self->prepare_protoschema({
486 parser_args => { sources => [$source->source_name], }
488 $self->_prepare_install({}, $proto_filename, $install_filename);
492 log_info { 'preparing deploy' };
494 $self->prepare_protoschema({}, '_ddl_protoschema_produce_filename');
495 $self->_prepare_install({}, '_ddl_protoschema_produce_filename', '_ddl_schema_produce_filename');
498 sub prepare_upgrade {
499 my ($self, $args) = @_;
501 "preparing upgrade from $args->{from_version} to $args->{to_version}"
503 $self->_prepare_changegrade(
504 $args->{from_version}, $args->{to_version}, $args->{version_set}, 'upgrade'
508 sub prepare_downgrade {
509 my ($self, $args) = @_;
511 "preparing downgrade from $args->{from_version} to $args->{to_version}"
513 $self->_prepare_changegrade(
514 $args->{from_version}, $args->{to_version}, $args->{version_set}, 'downgrade'
518 method _coderefs_per_files($files) {
519 no warnings 'redefine';
520 [map eval do { local( @ARGV, $/ ) = $_; <> }, @$files]
523 method _prepare_changegrade($from_version, $to_version, $version_set, $direction) {
524 my $schema = $self->schema;
525 my $databases = $self->databases;
526 my $dir = $self->script_directory;
528 my $schema_version = $self->schema_version;
529 my $diff_file_method = "_ddl_schema_${direction}_produce_filename";
530 foreach my $db (@$databases) {
531 my $diff_file = $self->$diff_file_method($db, $version_set, $dir );
533 carp("Overwriting existing $direction-diff file - $diff_file");
537 open my $file, q(>), $diff_file;
538 print {$file} join ";\n", @{$self->_sqldiff_from_yaml($from_version, $to_version, $db, $direction)};
543 method _read_sql_file($file) {
546 open my $fh, '<', $file;
547 my @data = split /;\n/, join '', <$fh>;
551 $_ && # remove blank lines
552 !/^(BEGIN|BEGIN TRANSACTION|COMMIT)/ # strip txn's
554 s/^\s+//; s/\s+$//; # trim whitespace
555 join '', grep { !/^--/ } split /\n/ # remove comments
561 sub downgrade_single_step {
563 my $version_set = (shift @_)->{version_set};
564 Dlog_info { "downgrade_single_step'ing $_" } $version_set;
566 my $sqlt_type = $self->storage->sqlt_type;
568 if ($self->ignore_ddl) {
569 $sql_to_run = $self->_sqldiff_from_yaml(
570 $version_set->[0], $version_set->[1], $sqlt_type, 'downgrade',
573 my $sql = $self->_run_sql_and_perl($self->_ddl_schema_downgrade_consume_filenames(
581 sub upgrade_single_step {
583 my $version_set = (shift @_)->{version_set};
584 Dlog_info { "upgrade_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, 'upgrade',
593 my $sql = $self->_run_sql_and_perl($self->_ddl_schema_upgrade_consume_filenames(
600 sub prepare_protoschema {
602 my $sqltargs = { %{$self->sql_translator_args}, %{shift @_} };
605 = $self->$to_file($self->schema_version);
607 # we do this because the code that uses this sets parser args,
608 # so we just need to merge in the package
609 $sqltargs->{parser_args}{package} = $self->schema;
610 my $sqlt = SQL::Translator->new({
611 parser => 'SQL::Translator::Parser::DBIx::Class',
612 producer => 'SQL::Translator::Producer::YAML',
616 my $yml = $sqlt->translate;
618 croak("Failed to translate to YAML: " . $sqlt->error)
622 carp "Overwriting existing DDL-YML file - $filename";
626 open my $file, q(>), $filename;
631 __PACKAGE__->meta->make_immutable;
635 # vim: ts=2 sw=2 expandtab
641 This class is the meat of L<DBIx::Class::DeploymentHandler>. It takes care
642 of generating serialized schemata as well as sql files to move from one
643 version of a schema to the rest. One of the hallmark features of this class
644 is that it allows for multiple sql files for deploy and upgrade, allowing
645 developers to fine tune deployment. In addition it also allows for perl
646 files to be run at any stage of the process.
648 For basic usage see L<DBIx::Class::DeploymentHandler::HandlesDeploy>. What's
649 documented here is extra fun stuff or private methods.
651 =head1 DIRECTORY LAYOUT
653 Arguably this is the best feature of L<DBIx::Class::DeploymentHandler>. It's
654 heavily based upon L<DBIx::Migration::Directories>, but has some extensions and
655 modifications, so even if you are familiar with it, please read this. I feel
656 like the best way to describe the layout is with the following example:
682 | | `- 002-remove-customers.pl
685 | `- 002-generate-customers.pl
692 | |- 001-create_database.pl
693 | `- 002-create_users_and_permissions.pl
701 So basically, the code
705 on an C<SQLite> database that would simply run
706 C<$sql_migration_dir/SQLite/deploy/1/001-auto.sql>. Next,
708 $dm->upgrade_single_step([1,2])
710 would run C<$sql_migration_dir/SQLite/upgrade/1-2/001-auto.sql> followed by
711 C<$sql_migration_dir/_common/upgrade/1-2/002-generate-customers.pl>.
713 C<.pl> files don't have to be in the C<_common> directory, but most of the time
714 they should be, because perl scripts are generally be database independent.
716 Note that unlike most steps in the process, C<preinstall> will not run SQL, as
717 there may not even be an database at preinstall time. It will run perl scripts
718 just like the other steps in the process, but nothing is passed to them.
719 Until people have used this more it will remain freeform, but a recommended use
720 of preinstall is to have it prompt for username and password, and then call the
721 appropriate C<< CREATE DATABASE >> commands etc.
723 =head2 Directory Specification
725 The following subdirectories are recognized by this DeployMethod:
729 =item C<_source> This directory can contain the following directories:
733 =item C<downgrade> This directory merely contains directories named after
734 migrations, which are of the form C<$from_version-$to_version>. Inside of
735 these directories you may put Perl scripts which are to return a subref
736 that takes the arguments C<< $from_schema, $to_schema >>, which are
737 L<SQL::Translator::Schema> objects.
739 =item C<upgrade> This directory merely contains directories named after
740 migrations, which are of the form C<$from_version-$to_version>. Inside of
741 these directories you may put Perl scripts which are to return a subref
742 that takes the arguments C<< $from_schema, $to_schema >>, which are
743 L<SQL::Translator::Schema> objects.
745 =item C<deploy> This directory merely contains directories named after schema
746 versions, which in turn contain C<yaml> files that are serialized versions
747 of the schema at that version. These files are not for editing by hand.
751 =item C<$storage_type> This is a set of scripts that gets run depending on what
752 your storage type is. If you are not sure what your storage type is, take a
753 look at the producers listed for L<SQL::Translator>. Also note, C<_common>
754 is a special case. C<_common> will get merged into whatever other files you
755 already have. This directory can containt the following directories itself:
759 =item C<preinstall> Gets run before the C<deploy> is C<deploy>ed. Has the
760 same structure as the C<deploy> subdirectory as well; that is, it has a
761 directory for each schema version. Unlike C<deploy>, C<upgrade>, and C<downgrade>
762 though, it can only run C<.pl> files, and the coderef in the perl files get
763 no arguments passed to them.
765 =item C<deploy> Gets run when the schema is C<deploy>ed. Structure is a
766 directory per schema version, and then files are merged with C<_common> and run
767 in filename order. C<.sql> files are merely run, as expected. C<.pl> files are
768 run according to L</PERL SCRIPTS>.
770 =item C<upgrade> Gets run when the schema is C<upgrade>d. Structure is a directory
771 per upgrade step, (for example, C<1-2> for upgrading from version 1 to version
772 2,) and then files are merged with C<_common> and run in filename order.
773 C<.sql> files are merely run, as expected. C<.pl> files are run according
776 =item C<downgrade> Gets run when the schema is C<downgrade>d. Structure is a directory
777 per downgrade step, (for example, C<2-1> for downgrading from version 2 to version
778 1,) and then files are merged with C<_common> and run in filename order.
779 C<.sql> files are merely run, as expected. C<.pl> files are run according
789 A perl script for this tool is very simple. It merely needs to contain an
790 anonymous sub that takes a L<DBIx::Class::Schema> as it's only argument.
791 A very basic perl script might look like:
801 $schema->resultset('Users')->create({
809 The L<DBIx::Class::Schema> (B<required>) that is used to talk to the database
810 and generate the DDL.
814 The L<DBIx::Class::Storage> that is I<actually> used to talk to the database
815 and generate the DDL. This is automatically created with L</_build_storage>.
817 =attr sql_translator_args
819 The arguments that get passed to L<SQL::Translator> when it's used.
821 =attr script_directory
823 The directory (default C<'sql'>) that scripts are stored in
827 The types of databases (default C<< [qw( MySQL SQLite PostgreSQL )] >>) to
832 Set to true (which is the default) to wrap all upgrades and deploys in a single
837 The version the schema on your harddrive is at. Defaults to
838 C<< $self->schema->schema_version >>.
842 =head2 __ddl_consume_with_prefix
844 $dm->__ddl_consume_with_prefix( 'SQLite', [qw( 1.00 1.01 )], 'upgrade' )
846 This is the meat of the multi-file upgrade/deploy stuff. It returns a list of
847 files in the order that they should be run for a generic "type" of upgrade.
848 You should not be calling this in user code.
850 =head2 _ddl_schema_consume_filenames
852 $dm->__ddl_schema_consume_filenames( 'SQLite', [qw( 1.00 )] )
854 Just a curried L</__ddl_consume_with_prefix>. Get's a list of files for an
857 =head2 _ddl_schema_produce_filename
859 $dm->__ddl_schema_produce_filename( 'SQLite', [qw( 1.00 )] )
861 Returns a single file in which an initial schema will be stored.
863 =head2 _ddl_schema_up_consume_filenames
865 $dm->_ddl_schema_up_consume_filenames( 'SQLite', [qw( 1.00 )] )
867 Just a curried L</__ddl_consume_with_prefix>. Get's a list of files for an
870 =head2 _ddl_schema_down_consume_filenames
872 $dm->_ddl_schema_down_consume_filenames( 'SQLite', [qw( 1.00 )] )
874 Just a curried L</__ddl_consume_with_prefix>. Get's a list of files for a
877 =head2 _ddl_schema_up_produce_filenames
879 $dm->_ddl_schema_up_produce_filename( 'SQLite', [qw( 1.00 1.01 )] )
881 Returns a single file in which the sql to upgrade from one schema to another
884 =head2 _ddl_schema_down_produce_filename
886 $dm->_ddl_schema_down_produce_filename( 'SQLite', [qw( 1.00 1.01 )] )
888 Returns a single file in which the sql to downgrade from one schema to another
891 =head2 _resultsource_install_filename
893 my $filename_fn = $dm->_resultsource_install_filename('User');
894 $dm->$filename_fn('SQLite', '1.00')
896 Returns a function which in turn returns a single filename used to install a
897 single resultsource. Weird interface is convenient for me. Deal with it.
899 =head2 _run_sql_and_perl
901 $dm->_run_sql_and_perl([qw( list of filenames )])
903 Simply put, this runs the list of files passed to it. If the file ends in
904 C<.sql> it runs it as sql and if it ends in C<.pl> it runs it as a perl file.
906 Depending on L</txn_wrap> all of the files run will be wrapped in a single
909 =head2 _prepare_install
911 $dm->_prepare_install({ add_drop_table => 0 }, sub { 'file_to_create' })
913 Generates the sql file for installing the database. First arg is simply
914 L<SQL::Translator> args and the second is a coderef that returns the filename
917 =head2 _prepare_changegrade
919 $dm->_prepare_changegrade('1.00', '1.01', [qw( 1.00 1.01)], 'upgrade')
921 Generates the sql file for migrating from one schema version to another. First
922 arg is the version to start from, second is the version to go to, third is the
923 L<version set|DBIx::Class::DeploymentHandler/VERSION SET>, and last is the
924 direction of the changegrade, be it 'upgrade' or 'downgrade'.
926 =head2 _read_sql_file
928 $dm->_read_sql_file('foo.sql')
930 Reads a sql file and returns lines in an C<ArrayRef>. Strips out comments,
931 transactions, and blank lines.