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 );
9 use Method::Signatures::Simple;
13 require SQL::Translator::Diff;
15 require DBIx::Class::Storage; # loaded for type constraint
16 use DBIx::Class::DeploymentHandler::Types;
18 use File::Path 'mkpath';
19 use File::Spec::Functions;
21 with 'DBIx::Class::DeploymentHandler::HandlesDeploy';
24 isa => 'DBIx::Class::Schema',
30 isa => 'DBIx::Class::Storage',
35 method _build_storage {
36 my $s = $self->schema->storage;
37 $s->_determine_driver;
41 has sql_translator_args => (
44 default => sub { {} },
46 has script_directory => (
55 isa => 'DBIx::Class::DeploymentHandler::Databases',
57 default => sub { [qw( MySQL SQLite PostgreSQL )] },
66 has schema_version => (
72 # this will probably never get called as the DBICDH
73 # will be passing down a schema_version normally, which
74 # is built the same way
75 method _build_schema_version { $self->schema->schema_version }
77 method __ddl_consume_with_prefix($type, $versions, $prefix) {
78 my $base_dir = $self->script_directory;
80 my $main = catfile( $base_dir, $type );
81 my $generic = catfile( $base_dir, '_generic' );
83 catfile( $base_dir, '_common', $prefix, join q(-), @{$versions} );
87 $dir = catfile($main, $prefix, join q(-), @{$versions})
88 } elsif (-d $generic) {
89 $dir = catfile($generic, $prefix, join q(-), @{$versions});
91 croak "neither $main or $generic exist; please write/generate some SQL";
94 opendir my($dh), $dir;
95 my %files = map { $_ => "$dir/$_" } grep { /\.(?:sql|pl)$/ && -f "$dir/$_" } readdir $dh;
99 opendir my($dh), $common;
100 for my $filename (grep { /\.(?:sql|pl)$/ && -f catfile($common,$_) } readdir $dh) {
101 unless ($files{$filename}) {
102 $files{$filename} = catfile($common,$filename);
108 return [@files{sort keys %files}]
111 method _ddl_preinstall_consume_filenames($type, $version) {
112 $self->__ddl_consume_with_prefix($type, [ $version ], 'preinstall')
115 method _ddl_schema_consume_filenames($type, $version) {
116 $self->__ddl_consume_with_prefix($type, [ $version ], 'schema')
119 method _ddl_schema_produce_filename($type, $version) {
120 my $dirname = catfile( $self->script_directory, $type, 'schema', $version );
121 mkpath($dirname) unless -d $dirname;
123 return catfile( $dirname, '001-auto.sql' );
126 method _ddl_schema_up_consume_filenames($type, $versions) {
127 $self->__ddl_consume_with_prefix($type, $versions, 'up')
130 method _ddl_schema_down_consume_filenames($type, $versions) {
131 $self->__ddl_consume_with_prefix($type, $versions, 'down')
134 method _ddl_schema_up_produce_filename($type, $versions) {
135 my $dir = $self->script_directory;
137 my $dirname = catfile( $dir, $type, 'up', join q(-), @{$versions});
138 mkpath($dirname) unless -d $dirname;
140 return catfile( $dirname, '001-auto.sql'
144 method _ddl_schema_down_produce_filename($type, $versions, $dir) {
145 my $dirname = catfile( $dir, $type, 'down', join q(-), @{$versions} );
146 mkpath($dirname) unless -d $dirname;
148 return catfile( $dirname, '001-auto.sql');
151 method _run_sql_and_perl($filenames) {
152 my @files = @{$filenames};
153 my $storage = $self->storage;
156 my $guard = $self->schema->txn_scope_guard if $self->txn_wrap;
159 for my $filename (@files) {
160 if ($filename =~ /\.sql$/) {
161 my @sql = @{$self->_read_sql_file($filename)};
162 $sql .= join "\n", @sql;
164 foreach my $line (@sql) {
165 $storage->_query_start($line);
167 # do a dbh_do cycle here, as we need some error checking in
168 # place (even though we will ignore errors)
169 $storage->dbh_do (sub { $_[1]->do($line) });
172 carp "$_ (running '${line}')"
174 $storage->_query_end($line);
176 } elsif ( $filename =~ /^(.+)\.pl$/ ) {
177 my $filedata = do { local( @ARGV, $/ ) = $filename; <> };
179 no warnings 'redefine';
180 my $fn = eval "$filedata";
184 carp "$filename failed to compile: $@";
185 } elsif (ref $fn eq 'CODE') {
188 carp "$filename should define an anonymouse sub that takes a schema but it didn't!";
191 croak "A file ($filename) got to deploy that wasn't sql or perl!";
195 $guard->commit if $self->txn_wrap;
202 my $version = (shift @_ || {})->{version} || $self->schema_version;
204 return $self->_run_sql_and_perl($self->_ddl_schema_consume_filenames(
205 $self->storage->sqlt_type,
213 my $version = $args->{version} || $self->schema_version;
214 my $storage_type = $args->{storage_type} || $self->storage->sqlt_type;
216 my @files = @{$self->_ddl_preinstall_consume_filenames(
221 for my $filename (@files) {
222 # We ignore sql for now (till I figure out what to do with it)
223 if ( $filename =~ /^(.+)\.pl$/ ) {
224 my $filedata = do { local( @ARGV, $/ ) = $filename; <> };
226 no warnings 'redefine';
227 my $fn = eval "$filedata";
231 carp "$filename failed to compile: $@";
232 } elsif (ref $fn eq 'CODE') {
235 carp "$filename should define an anonymous sub but it didn't!";
238 croak "A file ($filename) got to preinstall_scripts that wasn't sql or perl!";
243 sub _prepare_install {
245 my $sqltargs = { %{$self->sql_translator_args}, %{shift @_} };
247 my $schema = $self->schema;
248 my $databases = $self->databases;
249 my $dir = $self->script_directory;
250 my $version = $self->schema_version;
252 my $sqlt = SQL::Translator->new({
254 ignore_constraint_names => 1,
255 ignore_index_names => 1,
256 parser => 'SQL::Translator::Parser::DBIx::Class',
260 my $sqlt_schema = $sqlt->translate( data => $schema )
261 or croak($sqlt->error);
263 foreach my $db (@$databases) {
265 $sqlt->{schema} = $sqlt_schema;
266 $sqlt->producer($db);
268 my $filename = $self->$to_file($db, $version, $dir);
270 carp "Overwriting existing DDL file - $filename";
274 my $output = $sqlt->translate;
276 carp("Failed to translate to $db, skipping. (" . $sqlt->error . ")");
279 open my $file, q(>), $filename;
280 print {$file} $output;
285 sub _resultsource_install_filename {
286 my ($self, $source_name) = @_;
288 my ($self, $type, $version) = @_;
289 my $dirname = catfile( $self->script_directory, $type, 'schema', $version );
290 mkpath($dirname) unless -d $dirname;
292 return catfile( $dirname, "001-auto-$source_name.sql" );
296 sub install_resultsource {
297 my ($self, $args) = @_;
298 my $source = $args->{result_source};
299 my $version = $args->{version};
300 my $rs_install_file =
301 $self->_resultsource_install_filename($source->source_name);
304 $self->$rs_install_file(
305 $self->storage->sqlt_type,
309 $self->_run_sql_and_perl($files);
312 sub prepare_resultsource_install {
314 my $source = (shift @_)->{result_source};
316 my $filename = $self->_resultsource_install_filename($source->source_name);
317 $self->_prepare_install({
318 parser_args => { sources => [$source->source_name], }
324 $self->_prepare_install({}, '_ddl_schema_produce_filename');
327 sub prepare_upgrade {
328 my ($self, $args) = @_;
329 $self->_prepare_changegrade(
330 $args->{from_version}, $args->{to_version}, $args->{version_set}, 'up'
334 sub prepare_downgrade {
335 my ($self, $args) = @_;
336 $self->_prepare_changegrade(
337 $args->{from_version}, $args->{to_version}, $args->{version_set}, 'down'
341 method _prepare_changegrade($from_version, $to_version, $version_set, $direction) {
342 my $schema = $self->schema;
343 my $databases = $self->databases;
344 my $dir = $self->script_directory;
345 my $sqltargs = $self->sql_translator_args;
347 my $schema_version = $self->schema_version;
351 ignore_constraint_names => 1,
352 ignore_index_names => 1,
356 my $sqlt = SQL::Translator->new( $sqltargs );
358 $sqlt->parser('SQL::Translator::Parser::DBIx::Class');
359 my $sqlt_schema = $sqlt->translate( data => $schema )
360 or croak($sqlt->error);
362 foreach my $db (@$databases) {
364 $sqlt->{schema} = $sqlt_schema;
365 $sqlt->producer($db);
367 my $prefilename = $self->_ddl_schema_produce_filename($db, $from_version, $dir);
368 unless(-e $prefilename) {
369 carp("No previous schema file found ($prefilename)");
372 my $diff_file_method = "_ddl_schema_${direction}_produce_filename";
373 my $diff_file = $self->$diff_file_method($db, $version_set, $dir );
375 carp("Overwriting existing $direction-diff file - $diff_file");
381 my $t = SQL::Translator->new({
387 $t->parser( $db ) # could this really throw an exception?
390 my $out = $t->translate( $prefilename )
393 $source_schema = $t->schema;
395 $source_schema->name( $prefilename )
396 unless $source_schema->name;
399 # The "new" style of producers have sane normalization and can support
400 # diffing a SQL file against a DBIC->SQLT schema. Old style ones don't
401 # And we have to diff parsed SQL against parsed SQL.
402 my $dest_schema = $sqlt_schema;
404 unless ( "SQL::Translator::Producer::$db"->can('preprocess_schema') ) {
405 my $t = SQL::Translator->new({
411 $t->parser( $db ) # could this really throw an exception?
414 my $filename = $self->_ddl_schema_produce_filename($db, $to_version, $dir);
415 my $out = $t->translate( $filename )
418 $dest_schema = $t->schema;
420 $dest_schema->name( $filename )
421 unless $dest_schema->name;
424 my $diff = SQL::Translator::Diff::schema_diff(
429 open my $file, q(>), $diff_file;
435 method _read_sql_file($file) {
438 open my $fh, '<', $file;
439 my @data = split /;\n/, join '', <$fh>;
443 $_ && # remove blank lines
444 !/^(BEGIN|BEGIN TRANSACTION|COMMIT)/ # strip txn's
446 s/^\s+//; s/\s+$//; # trim whitespace
447 join '', grep { !/^--/ } split /\n/ # remove comments
453 sub downgrade_single_step {
455 my $version_set = (shift @_)->{version_set};
457 my $sql = $self->_run_sql_and_perl($self->_ddl_schema_down_consume_filenames(
458 $self->storage->sqlt_type,
465 sub upgrade_single_step {
467 my $version_set = (shift @_)->{version_set};
469 my $sql = $self->_run_sql_and_perl($self->_ddl_schema_up_consume_filenames(
470 $self->storage->sqlt_type,
476 __PACKAGE__->meta->make_immutable;
480 # vim: ts=2 sw=2 expandtab
486 This class is the meat of L<DBIx::Class::DeploymentHandler>. It takes care of
487 generating sql files representing schemata as well as sql files to move from
488 one version of a schema to the rest. One of the hallmark features of this
489 class is that it allows for multiple sql files for deploy and upgrade, allowing
490 developers to fine tune deployment. In addition it also allows for perl files
491 to be run at any stage of the process.
493 For basic usage see L<DBIx::Class::DeploymentHandler::HandlesDeploy>. What's
494 documented here is extra fun stuff or private methods.
496 =head1 DIRECTORY LAYOUT
498 Arguably this is the best feature of L<DBIx::Class::DeploymentHandler>. It's
499 heavily based upon L<DBIx::Migration::Directories>, but has some extensions and
500 modifications, so even if you are familiar with it, please read this. I feel
501 like the best way to describe the layout is with the following example:
519 | | `- 002-remove-customers.pl
522 | `- 002-generate-customers.pl
533 | `- 002-create-stored-procedures.sql
540 | |- 001-create_database.pl
541 | `- 002-create_users_and_permissions.pl
549 So basically, the code
553 on an C<SQLite> database that would simply run
554 C<$sql_migration_dir/SQLite/schema/1/001-auto.sql>. Next,
556 $dm->upgrade_single_step([1,2])
558 would run C<$sql_migration_dir/SQLite/up/1-2/001-auto.sql> followed by
559 C<$sql_migration_dir/_common/up/1-2/002-generate-customers.pl>.
561 Now, a C<.pl> file doesn't have to be in the C<_common> directory, but most of
562 the time it probably should be, since perl scripts will mostly be database
565 C<_generic> exists for when you for some reason are sure that your SQL is
566 generic enough to run on all databases. Good luck with that one.
568 Note that unlike most steps in the process, C<preinstall> will not run SQL, as
569 there may not even be an database at preinstall time. It will run perl scripts
570 just like the other steps in the process, but nothing is passed to them.
571 Until people have used this more it will remain freeform, but a recommended use
572 of preinstall is to have it prompt for username and password, and then call the
573 appropriate C<< CREATE DATABASE >> commands etc.
577 A perl script for this tool is very simple. It merely needs to contain an
578 anonymous sub that takes a L<DBIx::Class::Schema> as it's only argument.
579 A very basic perl script might look like:
589 $schema->resultset('Users')->create({
597 The L<DBIx::Class::Schema> (B<required>) that is used to talk to the database
598 and generate the DDL.
602 The L<DBIx::Class::Storage> that is I<actually> used to talk to the database
603 and generate the DDL. This is automatically created with L</_build_storage>.
605 =attr sql_translator_args
607 The arguments that get passed to L<SQL::Translator> when it's used.
609 =attr script_directory
611 The directory (default C<'sql'>) that scripts are stored in
615 The types of databases (default C<< [qw( MySQL SQLite PostgreSQL )] >>) to
620 Set to true (which is the default) to wrap all upgrades and deploys in a single
625 The version the schema on your harddrive is at. Defaults to
626 C<< $self->schema->schema_version >>.
630 =head2 __ddl_consume_with_prefix
632 $dm->__ddl_consume_with_prefix( 'SQLite', [qw( 1.00 1.01 )], 'up' )
634 This is the meat of the multi-file upgrade/deploy stuff. It returns a list of
635 files in the order that they should be run for a generic "type" of upgrade.
636 You should not be calling this in user code.
638 =head2 _ddl_schema_consume_filenames
640 $dm->__ddl_schema_consume_filenames( 'SQLite', [qw( 1.00 )] )
642 Just a curried L</__ddl_consume_with_prefix>. Get's a list of files for an
645 =head2 _ddl_schema_produce_filename
647 $dm->__ddl_schema_produce_filename( 'SQLite', [qw( 1.00 )] )
649 Returns a single file in which an initial schema will be stored.
651 =head2 _ddl_schema_up_consume_filenames
653 $dm->_ddl_schema_up_consume_filenames( 'SQLite', [qw( 1.00 )] )
655 Just a curried L</__ddl_consume_with_prefix>. Get's a list of files for an
658 =head2 _ddl_schema_down_consume_filenames
660 $dm->_ddl_schema_down_consume_filenames( 'SQLite', [qw( 1.00 )] )
662 Just a curried L</__ddl_consume_with_prefix>. Get's a list of files for a
665 =head2 _ddl_schema_up_produce_filenames
667 $dm->_ddl_schema_up_produce_filename( 'SQLite', [qw( 1.00 1.01 )] )
669 Returns a single file in which the sql to upgrade from one schema to another
672 =head2 _ddl_schema_down_produce_filename
674 $dm->_ddl_schema_down_produce_filename( 'SQLite', [qw( 1.00 1.01 )] )
676 Returns a single file in which the sql to downgrade from one schema to another
679 =head2 _resultsource_install_filename
681 my $filename_fn = $dm->_resultsource_install_filename('User');
682 $dm->$filename_fn('SQLite', '1.00')
684 Returns a function which in turn returns a single filename used to install a
685 single resultsource. Weird interface is convenient for me. Deal with it.
687 =head2 _run_sql_and_perl
689 $dm->_run_sql_and_perl([qw( list of filenames )])
691 Simply put, this runs the list of files passed to it. If the file ends in
692 C<.sql> it runs it as sql and if it ends in C<.pl> it runs it as a perl file.
694 Depending on L</txn_wrap> all of the files run will be wrapped in a single
697 =head2 _prepare_install
699 $dm->_prepare_install({ add_drop_table => 0 }, sub { 'file_to_create' })
701 Generates the sql file for installing the database. First arg is simply
702 L<SQL::Translator> args and the second is a coderef that returns the filename
705 =head2 _prepare_changegrade
707 $dm->_prepare_changegrade('1.00', '1.01', [qw( 1.00 1.01)], 'up')
709 Generates the sql file for migrating from one schema version to another. First
710 arg is the version to start from, second is the version to go to, third is the
711 L<version set|DBIx::Class::DeploymentHandler/VERSION SET>, and last is the
712 direction of the changegrade, be it 'up' or 'down'.
714 =head2 _read_sql_file
716 $dm->_read_sql_file('foo.sql')
718 Reads a sql file and returns lines in an C<ArrayRef>. Strips out comments,
719 transactions, and blank lines.