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 Log::Contextual::WarnLogger;
9 use Log::Contextual qw(:log :dlog), -default_logger => Log::Contextual::WarnLogger->new({
10 env_prefix => 'DBICDH'
12 use Data::Dumper::Concise;
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)$/ && -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_schema_produce_filename($type, $version) {
125 my $dirname = catfile( $self->script_directory, $type, 'schema', $version );
126 mkpath($dirname) unless -d $dirname;
128 return catfile( $dirname, '001-auto.sql' );
131 method _ddl_schema_up_consume_filenames($type, $versions) {
132 $self->__ddl_consume_with_prefix($type, $versions, 'up')
135 method _ddl_schema_down_consume_filenames($type, $versions) {
136 $self->__ddl_consume_with_prefix($type, $versions, 'down')
139 method _ddl_schema_up_produce_filename($type, $versions) {
140 my $dir = $self->script_directory;
142 my $dirname = catfile( $dir, $type, 'up', join q(-), @{$versions});
143 mkpath($dirname) unless -d $dirname;
145 return catfile( $dirname, '001-auto.sql'
149 method _ddl_schema_down_produce_filename($type, $versions, $dir) {
150 my $dirname = catfile( $dir, $type, 'down', join q(-), @{$versions} );
151 mkpath($dirname) unless -d $dirname;
153 return catfile( $dirname, '001-auto.sql');
156 method _run_sql($filename) {
157 my $storage = $self->storage;
158 log_debug { "[DBICDH] Running SQL from $filename" };
159 my @sql = @{$self->_read_sql_file($filename)};
160 my $sql .= join "\n", @sql;
161 log_trace { "[DBICDH] Running SQL $sql" };
163 foreach my $line (@sql) {
164 $storage->_query_start($line);
166 # do a dbh_do cycle here, as we need some error checking in
167 # place (even though we will ignore errors)
168 $storage->dbh_do (sub { $_[1]->do($line) });
171 carp "$_ (running '${line}')"
173 $storage->_query_end($line);
178 method _run_perl($filename) {
179 log_debug { "[DBICDH] Running Perl from $filename" };
180 my $filedata = do { local( @ARGV, $/ ) = $filename; <> };
182 no warnings 'redefine';
183 my $fn = eval "$filedata";
185 log_trace { '[DBICDH] Running Perl ' . Dumper($fn) };
188 carp "$filename failed to compile: $@";
189 } elsif (ref $fn eq 'CODE') {
192 carp "$filename should define an anonymouse sub that takes a schema but it didn't!";
196 method _run_serialized_sql($filename, $type) {
200 method _run_sql_and_perl($filenames) {
201 my $storage = $self->storage;
202 my @files = @{$filenames};
203 my $guard = $self->schema->txn_scope_guard if $self->txn_wrap;
206 for my $filename (@files) {
207 if ($filename =~ /\.sql$/) {
208 $sql .= $self->_run_sql($filename)
209 } elsif ( $filename =~ /\.sql-(\w+)$/ ) {
210 $sql .= $self->_run_serialized_sql($filename, $1)
211 } elsif ( $filename =~ /\.pl$/ ) {
212 $self->_run_perl($filename)
214 croak "A file ($filename) got to deploy that wasn't sql or perl!";
218 $guard->commit if $self->txn_wrap;
225 my $version = (shift @_ || {})->{version} || $self->schema_version;
226 log_info { "[DBICDH] deploying version $version" };
228 return $self->_run_sql_and_perl($self->_ddl_schema_consume_filenames(
229 $self->storage->sqlt_type,
237 my $version = $args->{version} || $self->schema_version;
238 log_info { "[DBICDH] preinstalling version $version" };
239 my $storage_type = $args->{storage_type} || $self->storage->sqlt_type;
241 my @files = @{$self->_ddl_preinstall_consume_filenames(
246 for my $filename (@files) {
247 # We ignore sql for now (till I figure out what to do with it)
248 if ( $filename =~ /^(.+)\.pl$/ ) {
249 my $filedata = do { local( @ARGV, $/ ) = $filename; <> };
251 no warnings 'redefine';
252 my $fn = eval "$filedata";
256 carp "$filename failed to compile: $@";
257 } elsif (ref $fn eq 'CODE') {
260 carp "$filename should define an anonymous sub but it didn't!";
263 croak "A file ($filename) got to preinstall_scripts that wasn't sql or perl!";
268 sub _prepare_install {
270 my $sqltargs = { %{$self->sql_translator_args}, %{shift @_} };
272 my $schema = $self->schema;
273 my $databases = $self->databases;
274 my $dir = $self->script_directory;
275 my $version = $self->schema_version;
277 my $sqlt = SQL::Translator->new({
279 ignore_constraint_names => 1,
280 ignore_index_names => 1,
281 parser => 'SQL::Translator::Parser::DBIx::Class',
285 my $sqlt_schema = $sqlt->translate( data => $schema )
286 or croak($sqlt->error);
288 foreach my $db (@$databases) {
290 $sqlt->{schema} = $sqlt_schema;
291 $sqlt->producer($db);
293 my $filename = $self->$to_file($db, $version, $dir);
295 carp "Overwriting existing DDL file - $filename";
299 my $output = $sqlt->translate;
301 carp("Failed to translate to $db, skipping. (" . $sqlt->error . ")");
304 open my $file, q(>), $filename;
305 print {$file} $output;
310 sub _resultsource_install_filename {
311 my ($self, $source_name) = @_;
313 my ($self, $type, $version) = @_;
314 my $dirname = catfile( $self->script_directory, $type, 'schema', $version );
315 mkpath($dirname) unless -d $dirname;
317 return catfile( $dirname, "001-auto-$source_name.sql" );
321 sub install_resultsource {
322 my ($self, $args) = @_;
323 my $source = $args->{result_source};
324 my $version = $args->{version};
325 log_info { '[DBICDH] installing_resultsource ' . $source->source_name . ", version $version" };
326 my $rs_install_file =
327 $self->_resultsource_install_filename($source->source_name);
330 $self->$rs_install_file(
331 $self->storage->sqlt_type,
335 $self->_run_sql_and_perl($files);
338 sub prepare_resultsource_install {
340 my $source = (shift @_)->{result_source};
341 log_info { '[DBICDH] preparing install for resultsource ' . $source->source_name };
343 my $filename = $self->_resultsource_install_filename($source->source_name);
344 $self->_prepare_install({
345 parser_args => { sources => [$source->source_name], }
350 log_info { '[DBICDH] preparing deploy' };
352 $self->_prepare_install({}, '_ddl_schema_produce_filename');
355 sub prepare_upgrade {
356 my ($self, $args) = @_;
358 '[DBICDH] preparing upgrade ' .
359 "from $args->{from_version} to $args->{to_version}"
361 $self->_prepare_changegrade(
362 $args->{from_version}, $args->{to_version}, $args->{version_set}, 'up'
366 sub prepare_downgrade {
367 my ($self, $args) = @_;
369 '[DBICDH] preparing downgrade ' .
370 "from $args->{from_version} to $args->{to_version}"
372 $self->_prepare_changegrade(
373 $args->{from_version}, $args->{to_version}, $args->{version_set}, 'down'
377 method _prepare_changegrade($from_version, $to_version, $version_set, $direction) {
378 my $schema = $self->schema;
379 my $databases = $self->databases;
380 my $dir = $self->script_directory;
381 my $sqltargs = $self->sql_translator_args;
383 my $schema_version = $self->schema_version;
387 ignore_constraint_names => 1,
388 ignore_index_names => 1,
392 my $sqlt = SQL::Translator->new( $sqltargs );
394 $sqlt->parser('SQL::Translator::Parser::DBIx::Class');
395 my $sqlt_schema = $sqlt->translate( data => $schema )
396 or croak($sqlt->error);
398 foreach my $db (@$databases) {
400 $sqlt->{schema} = $sqlt_schema;
401 $sqlt->producer($db);
403 my $prefilename = $self->_ddl_schema_produce_filename($db, $from_version, $dir);
404 unless(-e $prefilename) {
405 carp("No previous schema file found ($prefilename)");
408 my $diff_file_method = "_ddl_schema_${direction}_produce_filename";
409 my $diff_file = $self->$diff_file_method($db, $version_set, $dir );
411 carp("Overwriting existing $direction-diff file - $diff_file");
417 my $t = SQL::Translator->new({
423 $t->parser( $db ) # could this really throw an exception?
426 my $out = $t->translate( $prefilename )
429 $source_schema = $t->schema;
431 $source_schema->name( $prefilename )
432 unless $source_schema->name;
435 # The "new" style of producers have sane normalization and can support
436 # diffing a SQL file against a DBIC->SQLT schema. Old style ones don't
437 # And we have to diff parsed SQL against parsed SQL.
438 my $dest_schema = $sqlt_schema;
440 unless ( "SQL::Translator::Producer::$db"->can('preprocess_schema') ) {
441 my $t = SQL::Translator->new({
447 $t->parser( $db ) # could this really throw an exception?
450 my $filename = $self->_ddl_schema_produce_filename($db, $to_version, $dir);
451 my $out = $t->translate( $filename )
454 $dest_schema = $t->schema;
456 $dest_schema->name( $filename )
457 unless $dest_schema->name;
460 my $diff = SQL::Translator::Diff::schema_diff(
465 open my $file, q(>), $diff_file;
471 method _read_sql_file($file) {
474 open my $fh, '<', $file;
475 my @data = split /;\n/, join '', <$fh>;
479 $_ && # remove blank lines
480 !/^(BEGIN|BEGIN TRANSACTION|COMMIT)/ # strip txn's
482 s/^\s+//; s/\s+$//; # trim whitespace
483 join '', grep { !/^--/ } split /\n/ # remove comments
489 sub downgrade_single_step {
491 my $version_set = (shift @_)->{version_set};
492 log_info { qq([DBICDH] downgrade_single_step'ing ) . Dumper($version_set) };
494 my $sql = $self->_run_sql_and_perl($self->_ddl_schema_down_consume_filenames(
495 $self->storage->sqlt_type,
502 sub upgrade_single_step {
504 my $version_set = (shift @_)->{version_set};
505 log_info { qq([DBICDH] upgrade_single_step'ing ) . Dumper($version_set) };
507 my $sql = $self->_run_sql_and_perl($self->_ddl_schema_up_consume_filenames(
508 $self->storage->sqlt_type,
514 __PACKAGE__->meta->make_immutable;
518 # vim: ts=2 sw=2 expandtab
524 This class is the meat of L<DBIx::Class::DeploymentHandler>. It takes care of
525 generating sql files representing schemata as well as sql files to move from
526 one version of a schema to the rest. One of the hallmark features of this
527 class is that it allows for multiple sql files for deploy and upgrade, allowing
528 developers to fine tune deployment. In addition it also allows for perl files
529 to be run at any stage of the process.
531 For basic usage see L<DBIx::Class::DeploymentHandler::HandlesDeploy>. What's
532 documented here is extra fun stuff or private methods.
534 =head1 DIRECTORY LAYOUT
536 Arguably this is the best feature of L<DBIx::Class::DeploymentHandler>. It's
537 heavily based upon L<DBIx::Migration::Directories>, but has some extensions and
538 modifications, so even if you are familiar with it, please read this. I feel
539 like the best way to describe the layout is with the following example:
557 | | `- 002-remove-customers.pl
560 | `- 002-generate-customers.pl
571 | `- 002-create-stored-procedures.sql
578 | |- 001-create_database.pl
579 | `- 002-create_users_and_permissions.pl
587 So basically, the code
591 on an C<SQLite> database that would simply run
592 C<$sql_migration_dir/SQLite/schema/1/001-auto.sql>. Next,
594 $dm->upgrade_single_step([1,2])
596 would run C<$sql_migration_dir/SQLite/up/1-2/001-auto.sql> followed by
597 C<$sql_migration_dir/_common/up/1-2/002-generate-customers.pl>.
599 Now, a C<.pl> file doesn't have to be in the C<_common> directory, but most of
600 the time it probably should be, since perl scripts will mostly be database
603 C<_generic> exists for when you for some reason are sure that your SQL is
604 generic enough to run on all databases. Good luck with that one.
606 Note that unlike most steps in the process, C<preinstall> will not run SQL, as
607 there may not even be an database at preinstall time. It will run perl scripts
608 just like the other steps in the process, but nothing is passed to them.
609 Until people have used this more it will remain freeform, but a recommended use
610 of preinstall is to have it prompt for username and password, and then call the
611 appropriate C<< CREATE DATABASE >> commands etc.
615 A perl script for this tool is very simple. It merely needs to contain an
616 anonymous sub that takes a L<DBIx::Class::Schema> as it's only argument.
617 A very basic perl script might look like:
627 $schema->resultset('Users')->create({
635 The L<DBIx::Class::Schema> (B<required>) that is used to talk to the database
636 and generate the DDL.
640 The L<DBIx::Class::Storage> that is I<actually> used to talk to the database
641 and generate the DDL. This is automatically created with L</_build_storage>.
643 =attr sql_translator_args
645 The arguments that get passed to L<SQL::Translator> when it's used.
647 =attr script_directory
649 The directory (default C<'sql'>) that scripts are stored in
653 The types of databases (default C<< [qw( MySQL SQLite PostgreSQL )] >>) to
658 Set to true (which is the default) to wrap all upgrades and deploys in a single
663 The version the schema on your harddrive is at. Defaults to
664 C<< $self->schema->schema_version >>.
668 =head2 __ddl_consume_with_prefix
670 $dm->__ddl_consume_with_prefix( 'SQLite', [qw( 1.00 1.01 )], 'up' )
672 This is the meat of the multi-file upgrade/deploy stuff. It returns a list of
673 files in the order that they should be run for a generic "type" of upgrade.
674 You should not be calling this in user code.
676 =head2 _ddl_schema_consume_filenames
678 $dm->__ddl_schema_consume_filenames( 'SQLite', [qw( 1.00 )] )
680 Just a curried L</__ddl_consume_with_prefix>. Get's a list of files for an
683 =head2 _ddl_schema_produce_filename
685 $dm->__ddl_schema_produce_filename( 'SQLite', [qw( 1.00 )] )
687 Returns a single file in which an initial schema will be stored.
689 =head2 _ddl_schema_up_consume_filenames
691 $dm->_ddl_schema_up_consume_filenames( 'SQLite', [qw( 1.00 )] )
693 Just a curried L</__ddl_consume_with_prefix>. Get's a list of files for an
696 =head2 _ddl_schema_down_consume_filenames
698 $dm->_ddl_schema_down_consume_filenames( 'SQLite', [qw( 1.00 )] )
700 Just a curried L</__ddl_consume_with_prefix>. Get's a list of files for a
703 =head2 _ddl_schema_up_produce_filenames
705 $dm->_ddl_schema_up_produce_filename( 'SQLite', [qw( 1.00 1.01 )] )
707 Returns a single file in which the sql to upgrade from one schema to another
710 =head2 _ddl_schema_down_produce_filename
712 $dm->_ddl_schema_down_produce_filename( 'SQLite', [qw( 1.00 1.01 )] )
714 Returns a single file in which the sql to downgrade from one schema to another
717 =head2 _resultsource_install_filename
719 my $filename_fn = $dm->_resultsource_install_filename('User');
720 $dm->$filename_fn('SQLite', '1.00')
722 Returns a function which in turn returns a single filename used to install a
723 single resultsource. Weird interface is convenient for me. Deal with it.
725 =head2 _run_sql_and_perl
727 $dm->_run_sql_and_perl([qw( list of filenames )])
729 Simply put, this runs the list of files passed to it. If the file ends in
730 C<.sql> it runs it as sql and if it ends in C<.pl> it runs it as a perl file.
732 Depending on L</txn_wrap> all of the files run will be wrapped in a single
735 =head2 _prepare_install
737 $dm->_prepare_install({ add_drop_table => 0 }, sub { 'file_to_create' })
739 Generates the sql file for installing the database. First arg is simply
740 L<SQL::Translator> args and the second is a coderef that returns the filename
743 =head2 _prepare_changegrade
745 $dm->_prepare_changegrade('1.00', '1.01', [qw( 1.00 1.01)], 'up')
747 Generates the sql file for migrating from one schema version to another. First
748 arg is the version to start from, second is the version to go to, third is the
749 L<version set|DBIx::Class::DeploymentHandler/VERSION SET>, and last is the
750 direction of the changegrade, be it 'up' or 'down'.
752 =head2 _read_sql_file
754 $dm->_read_sql_file('foo.sql')
756 Reads a sql file and returns lines in an C<ArrayRef>. Strips out comments,
757 transactions, and blank lines.