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';
34 has force_overwrite => (
41 isa => 'DBIx::Class::Schema',
47 isa => 'DBIx::Class::Storage',
52 method _build_storage {
53 my $s = $self->schema->storage;
54 $s->_determine_driver;
58 has sql_translator_args => (
61 default => sub { {} },
63 has script_directory => (
72 isa => 'DBIx::Class::DeploymentHandler::Databases',
74 default => sub { [qw( MySQL SQLite PostgreSQL )] },
83 has schema_version => (
89 # this will probably never get called as the DBICDH
90 # will be passing down a schema_version normally, which
91 # is built the same way, but we leave this in place
92 method _build_schema_version { $self->schema->schema_version }
94 method __ddl_consume_with_prefix($type, $versions, $prefix) {
95 my $base_dir = $self->script_directory;
97 my $main = catfile( $base_dir, $type );
99 catfile( $base_dir, '_common', $prefix, join q(-), @{$versions} );
103 $dir = catfile($main, $prefix, join q(-), @{$versions})
105 if ($self->ignore_ddl) {
108 croak "$main does not exist; please write/generate some SQL"
114 opendir my($dh), $dir;
116 map { $_ => "$dir/$_" }
117 grep { /\.(?:sql|pl|sql-\w+)$/ && -f "$dir/$_" }
121 die $_ unless $self->ignore_ddl;
124 opendir my($dh), $common;
125 for my $filename (grep { /\.(?:sql|pl)$/ && -f catfile($common,$_) } readdir $dh) {
126 unless ($files{$filename}) {
127 $files{$filename} = catfile($common,$filename);
133 return [@files{sort keys %files}]
136 method _ddl_initialize_consume_filenames($type, $version) {
137 $self->__ddl_consume_with_prefix($type, [ $version ], 'initialize')
140 method _ddl_schema_consume_filenames($type, $version) {
141 $self->__ddl_consume_with_prefix($type, [ $version ], 'deploy')
144 method _ddl_protoschema_deploy_consume_filenames($version) {
145 my $base_dir = $self->script_directory;
147 my $dir = catfile( $base_dir, '_source', 'deploy', $version);
148 return [] unless -d $dir;
150 opendir my($dh), $dir;
151 my %files = map { $_ => "$dir/$_" } grep { /\.yml$/ && -f "$dir/$_" } readdir $dh;
154 return [@files{sort keys %files}]
157 method _ddl_protoschema_upgrade_consume_filenames($versions) {
158 my $base_dir = $self->script_directory;
160 my $dir = catfile( $base_dir, '_preprocess_schema', 'upgrade', join q(-), @{$versions});
162 return [] unless -d $dir;
164 opendir my($dh), $dir;
165 my %files = map { $_ => "$dir/$_" } grep { /\.pl$/ && -f "$dir/$_" } readdir $dh;
168 return [@files{sort keys %files}]
171 method _ddl_protoschema_downgrade_consume_filenames($versions) {
172 my $base_dir = $self->script_directory;
174 my $dir = catfile( $base_dir, '_preprocess_schema', 'downgrade', join q(-), @{$versions});
176 return [] unless -d $dir;
178 opendir my($dh), $dir;
179 my %files = map { $_ => "$dir/$_" } grep { /\.pl$/ && -f "$dir/$_" } readdir $dh;
182 return [@files{sort keys %files}]
185 method _ddl_protoschema_produce_filename($version) {
186 my $dirname = catfile( $self->script_directory, '_source', 'deploy', $version );
187 mkpath($dirname) unless -d $dirname;
189 return catfile( $dirname, '001-auto.yml' );
192 method _ddl_schema_produce_filename($type, $version) {
193 my $dirname = catfile( $self->script_directory, $type, 'deploy', $version );
194 mkpath($dirname) unless -d $dirname;
196 return catfile( $dirname, '001-auto.sql' );
199 method _ddl_schema_upgrade_consume_filenames($type, $versions) {
200 $self->__ddl_consume_with_prefix($type, $versions, 'upgrade')
203 method _ddl_schema_downgrade_consume_filenames($type, $versions) {
204 $self->__ddl_consume_with_prefix($type, $versions, 'downgrade')
207 method _ddl_schema_upgrade_produce_filename($type, $versions) {
208 my $dir = $self->script_directory;
210 my $dirname = catfile( $dir, $type, 'upgrade', join q(-), @{$versions});
211 mkpath($dirname) unless -d $dirname;
213 return catfile( $dirname, '001-auto.sql' );
216 method _ddl_schema_downgrade_produce_filename($type, $versions, $dir) {
217 my $dirname = catfile( $dir, $type, 'downgrade', join q(-), @{$versions} );
218 mkpath($dirname) unless -d $dirname;
220 return catfile( $dirname, '001-auto.sql');
223 method _run_sql_array($sql) {
224 my $storage = $self->storage;
227 $_ && # remove blank lines
228 !/^(BEGIN|BEGIN TRANSACTION|COMMIT)/ # strip txn's
230 s/^\s+//; s/\s+$//; # trim whitespace
231 join '', grep { !/^--/ } split /\n/ # remove comments
234 Dlog_trace { "Running SQL $_" } $sql;
235 foreach my $line (@{$sql}) {
236 $storage->_query_start($line);
237 # the whole reason we do this is so that we can see the line that was run
239 $storage->dbh_do (sub { $_[1]->do($line) });
242 die "$_ (running line '$line')"
244 $storage->_query_end($line);
246 return join "\n", @$sql
249 method _run_sql($filename) {
250 log_debug { "Running SQL from $filename" };
251 return $self->_run_sql_array($self->_read_sql_file($filename));
254 method _run_perl($filename) {
255 log_debug { "Running Perl from $filename" };
256 my $filedata = do { local( @ARGV, $/ ) = $filename; <> };
258 no warnings 'redefine';
259 my $fn = eval "$filedata";
261 Dlog_trace { "Running Perl $_" } $fn;
264 carp "$filename failed to compile: $@";
265 } elsif (ref $fn eq 'CODE') {
268 carp "$filename should define an anonymouse sub that takes a schema but it didn't!";
272 method _run_sql_and_perl($filenames, $sql_to_run) {
273 my @files = @{$filenames};
274 my $guard = $self->schema->txn_scope_guard if $self->txn_wrap;
276 $self->_run_sql_array($sql_to_run) if $self->ignore_ddl;
278 my $sql = ($sql_to_run)?join ";\n", @$sql_to_run:'';
280 for my $filename (@files) {
281 if ($self->ignore_ddl && $filename =~ /^[^_]*-auto.*\.sql$/) {
283 } elsif ($filename =~ /\.sql$/) {
284 $sql .= $self->_run_sql($filename)
285 } elsif ( $filename =~ /\.pl$/ ) {
286 $self->_run_perl($filename)
288 croak "A file ($filename) got to deploy that wasn't sql or perl!";
292 $guard->commit if $self->txn_wrap;
299 my $version = (shift @_ || {})->{version} || $self->schema_version;
300 log_info { "deploying version $version" };
301 my $sqlt_type = $self->storage->sqlt_type;
303 if ($self->ignore_ddl) {
304 $sql = $self->_sql_from_yaml({},
305 '_ddl_protoschema_deploy_consume_filenames', $sqlt_type
308 return $self->_run_sql_and_perl($self->_ddl_schema_consume_filenames(
317 my $version = $args->{version} || $self->schema_version;
318 log_info { "initializing version $version" };
319 my $storage_type = $args->{storage_type} || $self->storage->sqlt_type;
321 my @files = @{$self->_ddl_initialize_consume_filenames(
326 for my $filename (@files) {
327 # We ignore sql for now (till I figure out what to do with it)
328 if ( $filename =~ /^(.+)\.pl$/ ) {
329 my $filedata = do { local( @ARGV, $/ ) = $filename; <> };
331 no warnings 'redefine';
332 my $fn = eval "$filedata";
336 carp "$filename failed to compile: $@";
337 } elsif (ref $fn eq 'CODE') {
340 carp "$filename should define an anonymous sub but it didn't!";
343 croak "A file ($filename) got to initialize_scripts that wasn't sql or perl!";
348 method _sqldiff_from_yaml($from_version, $to_version, $db, $direction) {
349 my $dir = $self->script_directory;
352 ignore_constraint_names => 1,
353 ignore_index_names => 1,
354 %{$self->sql_translator_args}
359 my $prefilename = $self->_ddl_protoschema_produce_filename($from_version, $dir);
361 # should probably be a croak
362 carp("No previous schema file found ($prefilename)")
363 unless -e $prefilename;
365 my $t = SQL::Translator->new({
369 parser => 'SQL::Translator::Parser::YAML',
372 my $out = $t->translate( $prefilename )
375 $source_schema = $t->schema;
377 $source_schema->name( $prefilename )
378 unless $source_schema->name;
383 my $filename = $self->_ddl_protoschema_produce_filename($to_version, $dir);
385 # should probably be a croak
386 carp("No next schema file found ($filename)")
389 my $t = SQL::Translator->new({
393 parser => 'SQL::Translator::Parser::YAML',
396 my $out = $t->translate( $filename )
399 $dest_schema = $t->schema;
401 $dest_schema->name( $filename )
402 unless $dest_schema->name;
405 my $transform_files_method = "_ddl_protoschema_${direction}_consume_filenames";
406 my $transforms = $self->_coderefs_per_files(
407 $self->$transform_files_method([$from_version, $to_version])
409 $_->($source_schema, $dest_schema) for @$transforms;
411 return [SQL::Translator::Diff::schema_diff(
418 method _sql_from_yaml($sqltargs, $from_file, $db) {
419 my $schema = $self->schema;
420 my $version = $self->schema_version;
424 my $actual_file = $self->$from_file($version);
425 for my $yaml_filename (@{
426 DlogS_trace { "generating SQL from Serialized SQL Files: $_" }
427 (ref $actual_file?$actual_file:[$actual_file])
429 my $sqlt = SQL::Translator->new({
431 parser => 'SQL::Translator::Parser::YAML',
436 push @sql, $sqlt->translate($yaml_filename);
438 carp("Failed to translate to $db, skipping. (" . $sqlt->error . ")");
445 sub _prepare_install {
447 my $sqltargs = { %{$self->sql_translator_args}, %{shift @_} };
448 my $from_file = shift;
450 my $dir = $self->script_directory;
451 my $databases = $self->databases;
452 my $version = $self->schema_version;
454 foreach my $db (@$databases) {
455 my $sql = $self->_sql_from_yaml($sqltargs, $from_file, $db ) or next;
457 my $filename = $self->$to_file($db, $version, $dir);
459 if ($self->force_overwrite) {
460 carp "Overwriting existing DDL file - $filename";
463 die "Cannot overwrite '$filename', either enable force_overwrite or delete it"
466 open my $file, q(>), $filename;
467 print {$file} join ";\n", @$sql;
472 sub _resultsource_install_filename {
473 my ($self, $source_name) = @_;
475 my ($self, $type, $version) = @_;
476 my $dirname = catfile( $self->script_directory, $type, 'deploy', $version );
477 mkpath($dirname) unless -d $dirname;
479 return catfile( $dirname, "001-auto-$source_name.sql" );
483 sub _resultsource_protoschema_filename {
484 my ($self, $source_name) = @_;
486 my ($self, $version) = @_;
487 my $dirname = catfile( $self->script_directory, '_source', 'deploy', $version );
488 mkpath($dirname) unless -d $dirname;
490 return catfile( $dirname, "001-auto-$source_name.yml" );
494 sub install_resultsource {
495 my ($self, $args) = @_;
496 my $source = $args->{result_source}
497 or die 'result_source must be passed to install_resultsource';
498 my $version = $args->{version}
499 or die 'version must be passed to install_resultsource';
500 log_info { 'installing_resultsource ' . $source->source_name . ", version $version" };
501 my $rs_install_file =
502 $self->_resultsource_install_filename($source->source_name);
505 $self->$rs_install_file(
506 $self->storage->sqlt_type,
510 $self->_run_sql_and_perl($files);
513 sub prepare_resultsource_install {
515 my $source = (shift @_)->{result_source};
516 log_info { 'preparing install for resultsource ' . $source->source_name };
518 my $install_filename = $self->_resultsource_install_filename($source->source_name);
519 my $proto_filename = $self->_resultsource_protoschema_filename($source->source_name);
520 $self->prepare_protoschema({
521 parser_args => { sources => [$source->source_name], }
523 $self->_prepare_install({}, $proto_filename, $install_filename);
527 log_info { 'preparing deploy' };
529 $self->prepare_protoschema({
530 # Exclude __VERSION so that it gets installed separately
531 parser_args => { sources => [grep { $_ ne '__VERSION' } $self->schema->sources], }
532 }, '_ddl_protoschema_produce_filename');
533 $self->_prepare_install({}, '_ddl_protoschema_produce_filename', '_ddl_schema_produce_filename');
536 sub prepare_upgrade {
537 my ($self, $args) = @_;
539 "preparing upgrade from $args->{from_version} to $args->{to_version}"
541 $self->_prepare_changegrade(
542 $args->{from_version}, $args->{to_version}, $args->{version_set}, 'upgrade'
546 sub prepare_downgrade {
547 my ($self, $args) = @_;
549 "preparing downgrade from $args->{from_version} to $args->{to_version}"
551 $self->_prepare_changegrade(
552 $args->{from_version}, $args->{to_version}, $args->{version_set}, 'downgrade'
556 method _coderefs_per_files($files) {
557 no warnings 'redefine';
558 [map eval do { local( @ARGV, $/ ) = $_; <> }, @$files]
561 method _prepare_changegrade($from_version, $to_version, $version_set, $direction) {
562 my $schema = $self->schema;
563 my $databases = $self->databases;
564 my $dir = $self->script_directory;
566 my $schema_version = $self->schema_version;
567 my $diff_file_method = "_ddl_schema_${direction}_produce_filename";
568 foreach my $db (@$databases) {
569 my $diff_file = $self->$diff_file_method($db, $version_set, $dir );
571 if ($self->force_overwrite) {
572 carp("Overwriting existing $direction-diff file - $diff_file");
575 die "Cannot overwrite '$diff_file', either enable force_overwrite or delete it"
579 open my $file, q(>), $diff_file;
580 print {$file} join ";\n", @{$self->_sqldiff_from_yaml($from_version, $to_version, $db, $direction)};
585 method _read_sql_file($file) {
588 open my $fh, '<', $file;
589 my @data = split /;\n/, join '', <$fh>;
593 $_ && # remove blank lines
594 !/^(BEGIN|BEGIN TRANSACTION|COMMIT)/ # strip txn's
596 s/^\s+//; s/\s+$//; # trim whitespace
597 join '', grep { !/^--/ } split /\n/ # remove comments
603 sub downgrade_single_step {
605 my $version_set = (shift @_)->{version_set};
606 Dlog_info { "downgrade_single_step'ing $_" } $version_set;
608 my $sqlt_type = $self->storage->sqlt_type;
610 if ($self->ignore_ddl) {
611 $sql_to_run = $self->_sqldiff_from_yaml(
612 $version_set->[0], $version_set->[1], $sqlt_type, 'downgrade',
615 my $sql = $self->_run_sql_and_perl($self->_ddl_schema_downgrade_consume_filenames(
623 sub upgrade_single_step {
625 my $version_set = (shift @_)->{version_set};
626 Dlog_info { "upgrade_single_step'ing $_" } $version_set;
628 my $sqlt_type = $self->storage->sqlt_type;
630 if ($self->ignore_ddl) {
631 $sql_to_run = $self->_sqldiff_from_yaml(
632 $version_set->[0], $version_set->[1], $sqlt_type, 'upgrade',
635 my $sql = $self->_run_sql_and_perl($self->_ddl_schema_upgrade_consume_filenames(
642 sub prepare_protoschema {
644 my $sqltargs = { %{$self->sql_translator_args}, %{shift @_} };
647 = $self->$to_file($self->schema_version);
649 # we do this because the code that uses this sets parser args,
650 # so we just need to merge in the package
651 $sqltargs->{parser_args}{package} = $self->schema;
652 my $sqlt = SQL::Translator->new({
653 parser => 'SQL::Translator::Parser::DBIx::Class',
654 producer => 'SQL::Translator::Producer::YAML',
658 my $yml = $sqlt->translate;
660 croak("Failed to translate to YAML: " . $sqlt->error)
664 if ($self->force_overwrite) {
665 carp "Overwriting existing DDL-YML file - $filename";
668 die "Cannot overwrite '$filename', either enable force_overwrite or delete it"
672 open my $file, q(>), $filename;
677 __PACKAGE__->meta->make_immutable;
681 # vim: ts=2 sw=2 expandtab
687 This class is the meat of L<DBIx::Class::DeploymentHandler>. It takes care
688 of generating serialized schemata as well as sql files to move from one
689 version of a schema to the rest. One of the hallmark features of this class
690 is that it allows for multiple sql files for deploy and upgrade, allowing
691 developers to fine tune deployment. In addition it also allows for perl
692 files to be run at any stage of the process.
694 For basic usage see L<DBIx::Class::DeploymentHandler::HandlesDeploy>. What's
695 documented here is extra fun stuff or private methods.
697 =head1 DIRECTORY LAYOUT
699 Arguably this is the best feature of L<DBIx::Class::DeploymentHandler>.
700 It's spiritually based upon L<DBIx::Migration::Directories>, but has a
701 lot of extensions and modifications, so even if you are familiar with it,
702 please read this. I feel like the best way to describe the layout is with
703 the following example:
729 | | `- 002-remove-customers.pl
732 | `- 002-generate-customers.pl
739 | |- 001-create_database.pl
740 | `- 002-create_users_and_permissions.pl
748 So basically, the code
752 on an C<SQLite> database that would simply run
753 C<$sql_migration_dir/SQLite/deploy/1/001-auto.sql>. Next,
755 $dm->upgrade_single_step([1,2])
757 would run C<$sql_migration_dir/SQLite/upgrade/1-2/001-auto.sql> followed by
758 C<$sql_migration_dir/_common/upgrade/1-2/002-generate-customers.pl>.
760 C<.pl> files don't have to be in the C<_common> directory, but most of the time
761 they should be, because perl scripts are generally database independent.
763 Note that unlike most steps in the process, C<initialize> will not run SQL, as
764 there may not even be an database at initialize time. It will run perl scripts
765 just like the other steps in the process, but nothing is passed to them.
766 Until people have used this more it will remain freeform, but a recommended use
767 of initialize is to have it prompt for username and password, and then call the
768 appropriate C<< CREATE DATABASE >> commands etc.
770 =head2 Directory Specification
772 The following subdirectories are recognized by this DeployMethod:
776 =item C<_source> This directory can contain the following directories:
780 =item C<deploy> This directory merely contains directories named after schema
781 versions, which in turn contain C<yaml> files that are serialized versions
782 of the schema at that version. These files are not for editing by hand.
786 =item C<_preprocess_schema> This directory can contain the following
791 =item C<downgrade> This directory merely contains directories named after
792 migrations, which are of the form C<$from_version-$to_version>. Inside of
793 these directories you may put Perl scripts which are to return a subref
794 that takes the arguments C<< $from_schema, $to_schema >>, which are
795 L<SQL::Translator::Schema> objects.
797 =item C<upgrade> This directory merely contains directories named after
798 migrations, which are of the form C<$from_version-$to_version>. Inside of
799 these directories you may put Perl scripts which are to return a subref
800 that takes the arguments C<< $from_schema, $to_schema >>, which are
801 L<SQL::Translator::Schema> objects.
805 =item C<$storage_type> This is a set of scripts that gets run depending on what
806 your storage type is. If you are not sure what your storage type is, take a
807 look at the producers listed for L<SQL::Translator>. Also note, C<_common>
808 is a special case. C<_common> will get merged into whatever other files you
809 already have. This directory can containt the following directories itself:
813 =item C<initialize> Gets run before the C<deploy> is C<deploy>ed. Has the
814 same structure as the C<deploy> subdirectory as well; that is, it has a
815 directory for each schema version. Unlike C<deploy>, C<upgrade>, and C<downgrade>
816 though, it can only run C<.pl> files, and the coderef in the perl files get
817 no arguments passed to them.
819 =item C<deploy> Gets run when the schema is C<deploy>ed. Structure is a
820 directory per schema version, and then files are merged with C<_common> and run
821 in filename order. C<.sql> files are merely run, as expected. C<.pl> files are
822 run according to L</PERL SCRIPTS>.
824 =item C<upgrade> Gets run when the schema is C<upgrade>d. Structure is a directory
825 per upgrade step, (for example, C<1-2> for upgrading from version 1 to version
826 2,) and then files are merged with C<_common> and run in filename order.
827 C<.sql> files are merely run, as expected. C<.pl> files are run according
830 =item C<downgrade> Gets run when the schema is C<downgrade>d. Structure is a directory
831 per downgrade step, (for example, C<2-1> for downgrading from version 2 to version
832 1,) and then files are merged with C<_common> and run in filename order.
833 C<.sql> files are merely run, as expected. C<.pl> files are run according
843 A perl script for this tool is very simple. It merely needs to contain an
844 anonymous sub that takes a L<DBIx::Class::Schema> as it's only argument.
845 A very basic perl script might look like:
855 $schema->resultset('Users')->create({
863 This attribute will, when set to true (default is false), cause the DM to use
864 L<SQL::Translator> to use the C<_source>'s serialized SQL::Translator::Schema
865 instead of any pregenerated SQL. If you have a development server this is
866 probably the best plan of action as you will not be putting as many generated
867 files in your version control. Goes well with with C<databases> of C<[]>.
869 =attr force_overwrite
871 When this attribute is true generated files will be overwritten when the
872 methods which create such files are run again. The default is false, in which
873 case the program will die with a message saying which file needs to be deleted.
877 The L<DBIx::Class::Schema> (B<required>) that is used to talk to the database
878 and generate the DDL.
882 The L<DBIx::Class::Storage> that is I<actually> used to talk to the database
883 and generate the DDL. This is automatically created with L</_build_storage>.
885 =attr sql_translator_args
887 The arguments that get passed to L<SQL::Translator> when it's used.
889 =attr script_directory
891 The directory (default C<'sql'>) that scripts are stored in
895 The types of databases (default C<< [qw( MySQL SQLite PostgreSQL )] >>) to
900 Set to true (which is the default) to wrap all upgrades and deploys in a single
905 The version the schema on your harddrive is at. Defaults to
906 C<< $self->schema->schema_version >>.