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 }
82 method __ddl_consume_with_prefix($type, $versions, $prefix) {
83 my $base_dir = $self->script_directory;
85 my $main = catfile( $base_dir, $type );
86 my $generic = catfile( $base_dir, '_generic' );
88 catfile( $base_dir, '_common', $prefix, join q(-), @{$versions} );
92 $dir = catfile($main, $prefix, join q(-), @{$versions})
93 } elsif (-d $generic) {
94 $dir = catfile($generic, $prefix, join q(-), @{$versions});
96 croak "neither $main or $generic exist; please write/generate some SQL";
99 opendir my($dh), $dir;
100 my %files = map { $_ => "$dir/$_" } grep { /\.(?:sql|pl|sql-\w+)$/ && -f "$dir/$_" } readdir $dh;
104 opendir my($dh), $common;
105 for my $filename (grep { /\.(?:sql|pl)$/ && -f catfile($common,$_) } readdir $dh) {
106 unless ($files{$filename}) {
107 $files{$filename} = catfile($common,$filename);
113 return [@files{sort keys %files}]
116 method _ddl_preinstall_consume_filenames($type, $version) {
117 $self->__ddl_consume_with_prefix($type, [ $version ], 'preinstall')
120 method _ddl_schema_consume_filenames($type, $version) {
121 $self->__ddl_consume_with_prefix($type, [ $version ], 'schema')
124 method _ddl_protoschema_produce_filename($version) {
125 my $dirname = catfile( $self->script_directory, '_protoschema', $version );
126 mkpath($dirname) unless -d $dirname;
128 return catfile( $dirname, '001-auto.yml' );
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' );
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' );
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');
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 { "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 { "Running SQL from $filename" };
190 return $self->_run_sql_array($self->_read_sql_file($filename));
193 method _run_perl($filename) {
194 log_debug { "Running Perl from $filename" };
195 my $filedata = do { local( @ARGV, $/ ) = $filename; <> };
197 no warnings 'redefine';
198 my $fn = eval "$filedata";
200 Dlog_trace { "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_sql_and_perl($filenames) {
212 my @files = @{$filenames};
213 my $guard = $self->schema->txn_scope_guard if $self->txn_wrap;
216 for my $filename (@files) {
217 if ($filename =~ /\.sql$/) {
218 $sql .= $self->_run_sql($filename)
219 } elsif ( $filename =~ /\.pl$/ ) {
220 $self->_run_perl($filename)
222 croak "A file ($filename) got to deploy that wasn't sql or perl!";
226 $guard->commit if $self->txn_wrap;
233 my $version = (shift @_ || {})->{version} || $self->schema_version;
234 log_info { "deploying version $version" };
236 return $self->_run_sql_and_perl($self->_ddl_schema_consume_filenames(
237 $self->storage->sqlt_type,
245 my $version = $args->{version} || $self->schema_version;
246 log_info { "preinstalling version $version" };
247 my $storage_type = $args->{storage_type} || $self->storage->sqlt_type;
249 my @files = @{$self->_ddl_preinstall_consume_filenames(
254 for my $filename (@files) {
255 # We ignore sql for now (till I figure out what to do with it)
256 if ( $filename =~ /^(.+)\.pl$/ ) {
257 my $filedata = do { local( @ARGV, $/ ) = $filename; <> };
259 no warnings 'redefine';
260 my $fn = eval "$filedata";
264 carp "$filename failed to compile: $@";
265 } elsif (ref $fn eq 'CODE') {
268 carp "$filename should define an anonymous sub but it didn't!";
271 croak "A file ($filename) got to preinstall_scripts that wasn't sql or perl!";
276 sub _prepare_install {
278 my $sqltargs = { %{$self->sql_translator_args}, %{shift @_} };
279 my $from_file = shift;
281 my $schema = $self->schema;
282 my $databases = $self->databases;
283 my $dir = $self->script_directory;
284 my $version = $self->schema_version;
286 my $sqlt = SQL::Translator->new({
288 parser => 'SQL::Translator::Parser::YAML',
292 my $yaml_filename = $self->$from_file($version);
294 foreach my $db (@$databases) {
296 $sqlt->producer($db);
298 my $filename = $self->$to_file($db, $version, $dir);
300 carp "Overwriting existing DDL file - $filename";
304 my $sql = $sqlt->translate($yaml_filename);
306 carp("Failed to translate to $db, skipping. (" . $sqlt->error . ")");
309 open my $file, q(>), $filename;
315 sub _resultsource_install_filename {
316 my ($self, $source_name) = @_;
318 my ($self, $type, $version) = @_;
319 my $dirname = catfile( $self->script_directory, $type, 'schema', $version );
320 mkpath($dirname) unless -d $dirname;
322 return catfile( $dirname, "001-auto-$source_name.sql" );
326 sub _resultsource_protoschema_filename {
327 my ($self, $source_name) = @_;
329 my ($self, $version) = @_;
330 my $dirname = catfile( $self->script_directory, '_protoschema', $version );
331 mkpath($dirname) unless -d $dirname;
333 return catfile( $dirname, "001-auto-$source_name.yml" );
337 sub install_resultsource {
338 my ($self, $args) = @_;
339 my $source = $args->{result_source};
340 my $version = $args->{version};
341 log_info { 'installing_resultsource ' . $source->source_name . ", version $version" };
342 my $rs_install_file =
343 $self->_resultsource_install_filename($source->source_name);
346 $self->$rs_install_file(
347 $self->storage->sqlt_type,
351 $self->_run_sql_and_perl($files);
354 sub prepare_resultsource_install {
356 my $source = (shift @_)->{result_source};
357 log_info { 'preparing install for resultsource ' . $source->source_name };
359 my $install_filename = $self->_resultsource_install_filename($source->source_name);
360 my $proto_filename = $self->_resultsource_protoschema_filename($source->source_name);
361 $self->prepare_protoschema({
362 parser_args => { sources => [$source->source_name], }
364 $self->_prepare_install({}, $proto_filename, $install_filename);
368 log_info { 'preparing deploy' };
370 $self->prepare_protoschema({}, '_ddl_protoschema_produce_filename');
371 $self->_prepare_install({}, '_ddl_protoschema_produce_filename', '_ddl_schema_produce_filename');
374 sub prepare_upgrade {
375 my ($self, $args) = @_;
377 "preparing upgrade from $args->{from_version} to $args->{to_version}"
379 $self->_prepare_changegrade(
380 $args->{from_version}, $args->{to_version}, $args->{version_set}, 'up'
384 sub prepare_downgrade {
385 my ($self, $args) = @_;
387 "preparing downgrade from $args->{from_version} to $args->{to_version}"
389 $self->_prepare_changegrade(
390 $args->{from_version}, $args->{to_version}, $args->{version_set}, 'down'
394 method _prepare_changegrade($from_version, $to_version, $version_set, $direction) {
395 my $schema = $self->schema;
396 my $databases = $self->databases;
397 my $dir = $self->script_directory;
398 my $sqltargs = $self->sql_translator_args;
400 my $schema_version = $self->schema_version;
404 ignore_constraint_names => 1,
405 ignore_index_names => 1,
409 my $diff_file_method = "_ddl_schema_${direction}_produce_filename";
412 my $prefilename = $self->_ddl_protoschema_produce_filename($from_version, $dir);
414 # should probably be a croak
415 carp("No previous schema file found ($prefilename)")
416 unless -e $prefilename;
418 my $t = SQL::Translator->new({
422 parser => 'SQL::Translator::Parser::YAML',
425 my $out = $t->translate( $prefilename )
428 $source_schema = $t->schema;
430 $source_schema->name( $prefilename )
431 unless $source_schema->name;
436 my $filename = $self->_ddl_protoschema_produce_filename($to_version, $dir);
438 # should probably be a croak
439 carp("No next schema file found ($filename)")
442 my $t = SQL::Translator->new({
446 parser => 'SQL::Translator::Parser::YAML',
449 my $out = $t->translate( $filename )
452 $dest_schema = $t->schema;
454 $dest_schema->name( $filename )
455 unless $dest_schema->name;
457 foreach my $db (@$databases) {
458 my $diff_file = $self->$diff_file_method($db, $version_set, $dir );
460 carp("Overwriting existing $direction-diff file - $diff_file");
464 my $diff = SQL::Translator::Diff::schema_diff(
469 open my $file, q(>), $diff_file;
475 method _read_sql_file($file) {
478 open my $fh, '<', $file;
479 my @data = split /;\n/, join '', <$fh>;
483 $_ && # remove blank lines
484 !/^(BEGIN|BEGIN TRANSACTION|COMMIT)/ # strip txn's
486 s/^\s+//; s/\s+$//; # trim whitespace
487 join '', grep { !/^--/ } split /\n/ # remove comments
493 sub downgrade_single_step {
495 my $version_set = (shift @_)->{version_set};
496 Dlog_info { "downgrade_single_step'ing $_" } $version_set;
498 my $sql = $self->_run_sql_and_perl($self->_ddl_schema_down_consume_filenames(
499 $self->storage->sqlt_type,
506 sub upgrade_single_step {
508 my $version_set = (shift @_)->{version_set};
509 Dlog_info { "upgrade_single_step'ing $_" } $version_set;
511 my $sql = $self->_run_sql_and_perl($self->_ddl_schema_up_consume_filenames(
512 $self->storage->sqlt_type,
518 sub prepare_protoschema {
520 my $sqltargs = { %{$self->sql_translator_args}, %{shift @_} };
523 = $self->$to_file($self->schema_version);
525 # we do this because the code that uses this sets parser args,
526 # so we just need to merge in the package
527 $sqltargs->{parser_args}{package} = $self->schema;
528 my $sqlt = SQL::Translator->new({
529 parser => 'SQL::Translator::Parser::DBIx::Class',
530 producer => 'SQL::Translator::Producer::YAML',
534 my $yml = $sqlt->translate;
536 croak("Failed to translate to YAML: " . $sqlt->error)
540 carp "Overwriting existing DDL-YML file - $filename";
544 open my $file, q(>), $filename;
549 __PACKAGE__->meta->make_immutable;
553 # vim: ts=2 sw=2 expandtab
559 This class is the meat of L<DBIx::Class::DeploymentHandler>. It takes care
560 of generating serialized schemata as well as sql files to move from one
561 version of a schema to the rest. One of the hallmark features of this class
562 is that it allows for multiple sql files for deploy and upgrade, allowing
563 developers to fine tune deployment. In addition it also allows for perl
564 files to be run at any stage of the process.
566 For basic usage see L<DBIx::Class::DeploymentHandler::HandlesDeploy>. What's
567 documented here is extra fun stuff or private methods.
569 =head1 DIRECTORY LAYOUT
571 Arguably this is the best feature of L<DBIx::Class::DeploymentHandler>. It's
572 heavily based upon L<DBIx::Migration::Directories>, but has some extensions and
573 modifications, so even if you are familiar with it, please read this. I feel
574 like the best way to describe the layout is with the following example:
592 | | `- 002-remove-customers.pl
595 | `- 002-generate-customers.pl
606 | `- 002-create-stored-procedures.sql
613 | |- 001-create_database.pl
614 | `- 002-create_users_and_permissions.pl
622 So basically, the code
626 on an C<SQLite> database that would simply run
627 C<$sql_migration_dir/SQLite/schema/1/001-auto.sql>. Next,
629 $dm->upgrade_single_step([1,2])
631 would run C<$sql_migration_dir/SQLite/up/1-2/001-auto.sql> followed by
632 C<$sql_migration_dir/_common/up/1-2/002-generate-customers.pl>.
634 C<.pl> files don't have to be in the C<_common> directory, but most of the time
635 they should be, because perl scripts are generally be database independent.
637 C<_generic> exists for when you for some reason are sure that your SQL is
638 generic enough to run on all databases. Good luck with that one.
640 Note that unlike most steps in the process, C<preinstall> will not run SQL, as
641 there may not even be an database at preinstall time. It will run perl scripts
642 just like the other steps in the process, but nothing is passed to them.
643 Until people have used this more it will remain freeform, but a recommended use
644 of preinstall is to have it prompt for username and password, and then call the
645 appropriate C<< CREATE DATABASE >> commands etc.
649 A perl script for this tool is very simple. It merely needs to contain an
650 anonymous sub that takes a L<DBIx::Class::Schema> as it's only argument.
651 A very basic perl script might look like:
661 $schema->resultset('Users')->create({
669 The L<DBIx::Class::Schema> (B<required>) that is used to talk to the database
670 and generate the DDL.
674 The L<DBIx::Class::Storage> that is I<actually> used to talk to the database
675 and generate the DDL. This is automatically created with L</_build_storage>.
677 =attr sql_translator_args
679 The arguments that get passed to L<SQL::Translator> when it's used.
681 =attr script_directory
683 The directory (default C<'sql'>) that scripts are stored in
687 The types of databases (default C<< [qw( MySQL SQLite PostgreSQL )] >>) to
692 Set to true (which is the default) to wrap all upgrades and deploys in a single
697 The version the schema on your harddrive is at. Defaults to
698 C<< $self->schema->schema_version >>.
702 =head2 __ddl_consume_with_prefix
704 $dm->__ddl_consume_with_prefix( 'SQLite', [qw( 1.00 1.01 )], 'up' )
706 This is the meat of the multi-file upgrade/deploy stuff. It returns a list of
707 files in the order that they should be run for a generic "type" of upgrade.
708 You should not be calling this in user code.
710 =head2 _ddl_schema_consume_filenames
712 $dm->__ddl_schema_consume_filenames( 'SQLite', [qw( 1.00 )] )
714 Just a curried L</__ddl_consume_with_prefix>. Get's a list of files for an
717 =head2 _ddl_schema_produce_filename
719 $dm->__ddl_schema_produce_filename( 'SQLite', [qw( 1.00 )] )
721 Returns a single file in which an initial schema will be stored.
723 =head2 _ddl_schema_up_consume_filenames
725 $dm->_ddl_schema_up_consume_filenames( 'SQLite', [qw( 1.00 )] )
727 Just a curried L</__ddl_consume_with_prefix>. Get's a list of files for an
730 =head2 _ddl_schema_down_consume_filenames
732 $dm->_ddl_schema_down_consume_filenames( 'SQLite', [qw( 1.00 )] )
734 Just a curried L</__ddl_consume_with_prefix>. Get's a list of files for a
737 =head2 _ddl_schema_up_produce_filenames
739 $dm->_ddl_schema_up_produce_filename( 'SQLite', [qw( 1.00 1.01 )] )
741 Returns a single file in which the sql to upgrade from one schema to another
744 =head2 _ddl_schema_down_produce_filename
746 $dm->_ddl_schema_down_produce_filename( 'SQLite', [qw( 1.00 1.01 )] )
748 Returns a single file in which the sql to downgrade from one schema to another
751 =head2 _resultsource_install_filename
753 my $filename_fn = $dm->_resultsource_install_filename('User');
754 $dm->$filename_fn('SQLite', '1.00')
756 Returns a function which in turn returns a single filename used to install a
757 single resultsource. Weird interface is convenient for me. Deal with it.
759 =head2 _run_sql_and_perl
761 $dm->_run_sql_and_perl([qw( list of filenames )])
763 Simply put, this runs the list of files passed to it. If the file ends in
764 C<.sql> it runs it as sql and if it ends in C<.pl> it runs it as a perl file.
766 Depending on L</txn_wrap> all of the files run will be wrapped in a single
769 =head2 _prepare_install
771 $dm->_prepare_install({ add_drop_table => 0 }, sub { 'file_to_create' })
773 Generates the sql file for installing the database. First arg is simply
774 L<SQL::Translator> args and the second is a coderef that returns the filename
777 =head2 _prepare_changegrade
779 $dm->_prepare_changegrade('1.00', '1.01', [qw( 1.00 1.01)], 'up')
781 Generates the sql file for migrating from one schema version to another. First
782 arg is the version to start from, second is the version to go to, third is the
783 L<version set|DBIx::Class::DeploymentHandler/VERSION SET>, and last is the
784 direction of the changegrade, be it 'up' or 'down'.
786 =head2 _read_sql_file
788 $dm->_read_sql_file('foo.sql')
790 Reads a sql file and returns lines in an C<ArrayRef>. Strips out comments,
791 transactions, and blank lines.