1 package DBIx::Class::DeploymentHandler::DeployMethod::SQL::Translator;
5 use Carp qw( carp croak );
7 use Method::Signatures::Simple;
11 require SQL::Translator::Diff;
13 require DBIx::Class::Storage; # loaded for type constraint
14 use DBIx::Class::DeploymentHandler::Types;
16 use File::Path 'mkpath';
17 use File::Spec::Functions;
19 with 'DBIx::Class::DeploymentHandler::HandlesDeploy';
22 isa => 'DBIx::Class::Schema',
28 isa => 'DBIx::Class::Storage',
33 method _build_storage {
34 my $s = $self->schema->storage;
35 $s->_determine_driver;
42 default => sub { {} },
44 has upgrade_directory => (
53 isa => 'DBIx::Class::DeploymentHandler::Databases',
55 default => sub { [qw( MySQL SQLite PostgreSQL )] },
64 has schema_version => (
69 method _build_schema_version { $self->schema->schema_version }
71 method __ddl_consume_with_prefix($type, $versions, $prefix) {
72 my $base_dir = $self->upgrade_directory;
74 my $main = catfile( $base_dir, $type );
75 my $generic = catfile( $base_dir, '_generic' );
77 catfile( $base_dir, '_common', $prefix, join q(-), @{$versions} );
81 $dir = catfile($main, $prefix, join q(-), @{$versions})
82 } elsif (-d $generic) {
83 $dir = catfile($generic, $prefix, join q(-), @{$versions});
85 croak "neither $main or $generic exist; please write/generate some SQL";
88 opendir my($dh), $dir;
89 my %files = map { $_ => "$dir/$_" } grep { /\.(?:sql|pl)$/ && -f "$dir/$_" } readdir $dh;
93 opendir my($dh), $common;
94 for my $filename (grep { /\.(?:sql|pl)$/ && -f catfile($common,$_) } readdir $dh) {
95 unless ($files{$filename}) {
96 $files{$filename} = catfile($common,$filename);
102 return [@files{sort keys %files}]
105 method _ddl_schema_consume_filenames($type, $version) {
106 $self->__ddl_consume_with_prefix($type, [ $version ], 'schema')
109 method _ddl_schema_produce_filename($type, $version) {
110 my $dirname = catfile( $self->upgrade_directory, $type, 'schema', $version );
111 mkpath($dirname) unless -d $dirname;
113 return catfile( $dirname, '001-auto.sql' );
116 method _ddl_schema_up_consume_filenames($type, $versions) {
117 $self->__ddl_consume_with_prefix($type, $versions, 'up')
120 method _ddl_schema_down_consume_filenames($type, $versions) {
121 $self->__ddl_consume_with_prefix($type, $versions, 'down')
124 method _ddl_schema_up_produce_filename($type, $versions) {
125 my $dir = $self->upgrade_directory;
127 my $dirname = catfile( $dir, $type, 'up', join q(-), @{$versions});
128 mkpath($dirname) unless -d $dirname;
130 return catfile( $dirname, '001-auto.sql'
134 method _ddl_schema_down_produce_filename($type, $versions, $dir) {
135 my $dirname = catfile( $dir, $type, 'down', join q(-), @{$versions} );
136 mkpath($dirname) unless -d $dirname;
138 return catfile( $dirname, '001-auto.sql');
141 method _run_sql_and_perl($filenames) {
142 my @files = @{$filenames};
143 my $storage = $self->storage;
146 my $guard = $self->schema->txn_scope_guard if $self->txn_wrap;
149 for my $filename (@files) {
150 if ($filename =~ /\.sql$/) {
151 my @sql = @{$self->_read_sql_file($filename)};
152 $sql .= join "\n", @sql;
154 foreach my $line (@sql) {
155 $storage->_query_start($line);
157 # do a dbh_do cycle here, as we need some error checking in
158 # place (even though we will ignore errors)
159 $storage->dbh_do (sub { $_[1]->do($line) });
162 carp "$_ (running '${line}')"
164 $storage->_query_end($line);
166 } elsif ( $filename =~ /^(.+)\.pl$/ ) {
168 my $filedata = do { local( @ARGV, $/ ) = $filename; <> };
169 # make the package name more palateable to perl
170 $package =~ s/\W/_/g;
172 no warnings 'redefine';
173 eval "package $package;\n\n$filedata";
176 if (my $fn = $package->can('run')) {
177 $fn->($self->schema);
179 carp "$filename should define a run method that takes a schema but it didn't!";
182 croak "A file got to deploy that wasn't sql or perl!";
186 $guard->commit if $self->txn_wrap;
193 my $version = shift || $self->schema_version;
195 return $self->_run_sql_and_perl($self->_ddl_schema_consume_filenames(
196 $self->storage->sqlt_type,
201 sub _prepare_install {
203 my $sqltargs = { %{$self->sqltargs}, %{shift @_} };
205 my $schema = $self->schema;
206 my $databases = $self->databases;
207 my $dir = $self->upgrade_directory;
208 my $version = $self->schema_version;
210 my $sqlt = SQL::Translator->new({
212 ignore_constraint_names => 1,
213 ignore_index_names => 1,
214 parser => 'SQL::Translator::Parser::DBIx::Class',
218 my $sqlt_schema = $sqlt->translate( data => $schema )
219 or croak($sqlt->error);
221 foreach my $db (@$databases) {
223 $sqlt->{schema} = $sqlt_schema;
224 $sqlt->producer($db);
226 my $filename = $self->$to_file($db, $version, $dir);
228 carp "Overwriting existing DDL file - $filename";
232 my $output = $sqlt->translate;
234 carp("Failed to translate to $db, skipping. (" . $sqlt->error . ")");
237 open my $file, q(>), $filename;
238 print {$file} $output;
243 sub _resultsource_install_filename {
244 my ($self, $source_name) = @_;
246 my ($self, $type, $version) = @_;
247 my $dirname = catfile( $self->upgrade_directory, $type, 'schema', $version );
248 mkpath($dirname) unless -d $dirname;
250 return catfile( $dirname, "001-auto-$source_name.sql" );
254 sub install_resultsource {
255 my ($self, $source, $version) = @_;
257 my $rs_install_file =
258 $self->_resultsource_install_filename($source->source_name);
261 $self->$rs_install_file(
262 $self->storage->sqlt_type,
266 $self->_run_sql_and_perl($files);
269 sub prepare_resultsource_install {
273 my $filename = $self->_resultsource_install_filename($source->source_name);
274 $self->_prepare_install({
275 parser_args => { sources => [$source->source_name], }
281 $self->_prepare_install({}, '_ddl_schema_produce_filename');
284 sub prepare_upgrade {
285 my ($self, $from_version, $to_version, $version_set) = @_;
286 $self->_prepare_changegrade($from_version, $to_version, $version_set, 'up');
289 sub prepare_downgrade {
290 my ($self, $from_version, $to_version, $version_set) = @_;
292 $self->_prepare_changegrade($from_version, $to_version, $version_set, 'down');
295 method _prepare_changegrade($from_version, $to_version, $version_set, $direction) {
296 my $schema = $self->schema;
297 my $databases = $self->databases;
298 my $dir = $self->upgrade_directory;
299 my $sqltargs = $self->sqltargs;
301 my $schema_version = $self->schema_version;
305 ignore_constraint_names => 1,
306 ignore_index_names => 1,
310 my $sqlt = SQL::Translator->new( $sqltargs );
312 $sqlt->parser('SQL::Translator::Parser::DBIx::Class');
313 my $sqlt_schema = $sqlt->translate( data => $schema )
314 or croak($sqlt->error);
316 foreach my $db (@$databases) {
318 $sqlt->{schema} = $sqlt_schema;
319 $sqlt->producer($db);
321 my $prefilename = $self->_ddl_schema_produce_filename($db, $from_version, $dir);
322 unless(-e $prefilename) {
323 carp("No previous schema file found ($prefilename)");
326 my $diff_file_method = "_ddl_schema_${direction}_produce_filename";
327 my $diff_file = $self->$diff_file_method($db, $version_set, $dir );
329 carp("Overwriting existing $direction-diff file - $diff_file");
335 my $t = SQL::Translator->new({
341 $t->parser( $db ) # could this really throw an exception?
344 my $out = $t->translate( $prefilename )
347 $source_schema = $t->schema;
349 $source_schema->name( $prefilename )
350 unless $source_schema->name;
353 # The "new" style of producers have sane normalization and can support
354 # diffing a SQL file against a DBIC->SQLT schema. Old style ones don't
355 # And we have to diff parsed SQL against parsed SQL.
356 my $dest_schema = $sqlt_schema;
358 unless ( "SQL::Translator::Producer::$db"->can('preprocess_schema') ) {
359 my $t = SQL::Translator->new({
365 $t->parser( $db ) # could this really throw an exception?
368 my $filename = $self->_ddl_schema_produce_filename($db, $to_version, $dir);
369 my $out = $t->translate( $filename )
372 $dest_schema = $t->schema;
374 $dest_schema->name( $filename )
375 unless $dest_schema->name;
378 my $diff = SQL::Translator::Diff::schema_diff(
383 open my $file, q(>), $diff_file;
389 method _read_sql_file($file) {
392 open my $fh, '<', $file;
393 my @data = split /;\n/, join '', <$fh>;
397 $_ && # remove blank lines
398 !/^(BEGIN|BEGIN TRANSACTION|COMMIT)/ # strip txn's
400 s/^\s+//; s/\s+$//; # trim whitespace
401 join '', grep { !/^--/ } split /\n/ # remove comments
407 sub downgrade_single_step {
409 my $version_set = shift @_;
411 my $sql = $self->_run_sql_and_perl($self->_ddl_schema_down_consume_filenames(
412 $self->storage->sqlt_type,
419 sub upgrade_single_step {
421 my $version_set = shift @_;
423 my $sql = $self->_run_sql_and_perl($self->_ddl_schema_up_consume_filenames(
424 $self->storage->sqlt_type,
430 __PACKAGE__->meta->make_immutable;
434 # vim: ts=2 sw=2 expandtab
440 This class is the meat of L<DBIx::Class::DeploymentHandler>. It takes care of
441 generating sql files representing schemata as well as sql files to move from
442 one version of a schema to the rest. One of the hallmark features of this
443 class is that it allows for multiple sql files for deploy and upgrade, allowing
444 developers to fine tune deployment. In addition it also allows for perl files
445 to be run at any stage of the process.
447 For basic usage see L<DBIx::Class::DeploymentHandler::HandlesDeploy>. What's
448 documented here is extra fun stuff or private methods.
450 =head1 DIRECTORY LAYOUT
452 Arguably this is the best feature of L<DBIx::Class::DeploymentHandler>. It's
453 heavily based upon L<DBIx::Migration::Directories>, but has some extensions and
454 modifications, so even if you are familiar with it, please read this. I feel
455 like the best way to describe the layout is with the following example:
473 | | `- 002-remove-customers.pl
476 | `- 002-generate-customers.pl
487 | `- 002-create-stored-procedures.sql
499 So basically, the code
503 on an C<SQLite> database that would simply run
504 C<$sql_migration_dir/SQLite/schema/1/001-auto.sql>. Next,
506 $dm->upgrade_single_step([1,2])
508 would run C<$sql_migration_dir/SQLite/up/1-2/001-auto.sql> followed by
509 C<$sql_migration_dir/_common/up/1-2/002-generate-customers.pl>.
511 Now, a C<.pl> file doesn't have to be in the C<_common> directory, but most of
512 the time it probably should be, since perl scripts will mostly be database
515 C<_generic> exists for when you for some reason are sure that your SQL is
516 generic enough to run on all databases. Good luck with that one.
520 A perl script for this tool is very simple. It merely needs to contain a
521 sub called C<run> that takes a L<DBIx::Class::Schema> as it's only argument.
522 A very basic perl script might look like:
532 $schema->resultset('Users')->create({
540 The L<DBIx::Class::Schema> (B<required>) that is used to talk to the database
541 and generate the DDL.
545 The L<DBIx::Class::Storage> that is I<actually> used to talk to the database
546 and generate the DDL. This is automatically created with L</_build_storage>.
553 =attr upgrade_directory
555 The directory (default C<'sql'>) that upgrades are stored in
559 The types of databases (default C<< [qw( MySQL SQLite PostgreSQL )] >>) to
564 Set to true (which is the default) to wrap all upgrades and deploys in a single
569 The version the schema on your harddrive is at. Defaults to
570 C<< $self->schema->schema_version >>.
572 =method __ddl_consume_with_prefix
574 $dm->__ddl_consume_with_prefix( 'SQLite', [qw( 1.00 1.01 )], 'up' )
576 This is the meat of the multi-file upgrade/deploy stuff. It returns a list of
577 files in the order that they should be run for a generic "type" of upgrade.
578 You should not be calling this in user code.
580 =method _ddl_schema_consume_filenames
582 $dm->__ddl_schema_consume_filenames( 'SQLite', [qw( 1.00 )] )
584 Just a curried L</__ddl_consume_with_prefix>. Get's a list of files for an
587 =method _ddl_schema_produce_filename
589 $dm->__ddl_schema_produce_filename( 'SQLite', [qw( 1.00 )] )
591 Returns a single file in which an initial schema will be stored.
593 =method _ddl_schema_up_consume_filenames
595 $dm->_ddl_schema_up_consume_filenames( 'SQLite', [qw( 1.00 )] )
597 Just a curried L</__ddl_consume_with_prefix>. Get's a list of files for an
600 =method _ddl_schema_down_consume_filenames
602 $dm->_ddl_schema_down_consume_filenames( 'SQLite', [qw( 1.00 )] )
604 Just a curried L</__ddl_consume_with_prefix>. Get's a list of files for a
607 =method _ddl_schema_up_produce_filenames
609 $dm->_ddl_schema_up_produce_filename( 'SQLite', [qw( 1.00 1.01 )] )
611 Returns a single file in which the sql to upgrade from one schema to another
614 =method _ddl_schema_down_produce_filename
616 $dm->_ddl_schema_down_produce_filename( 'SQLite', [qw( 1.00 1.01 )] )
618 Returns a single file in which the sql to downgrade from one schema to another
621 =method _resultsource_install_filename
623 my $filename_fn = $dm->_resultsource_install_filename('User');
624 $dm->$filename_fn('SQLite', '1.00')
626 Returns a function which in turn returns a single filename used to install a
627 single resultsource. Weird interface is convenient for me. Deal with it.
629 =method _run_sql_and_perl
631 $dm->_run_sql_and_perl([qw( list of filenames )])
633 Simply put, this runs the list of files passed to it. If the file ends in
634 C<.sql> it runs it as sql and if it ends in C<.pl> it runs it as a perl file.
636 Depending on L</txn_wrap> all of the files run will be wrapped in a single
639 =method _prepare_install
641 $dm->_prepare_install({ add_drop_table => 0 }, sub { 'file_to_create' })
643 Generates the sql file for installing the database. First arg is simply
644 L<SQL::Translator> args and the second is a coderef that returns the filename
647 =method _prepare_changegrade
649 $dm->_prepare_changegrade('1.00', '1.01', [qw( 1.00 1.01)], 'up')
651 Generates the sql file for migrating from one schema version to another. First
652 arg is the version to start from, second is the version to go to, third is the
653 L<version set|DBIx::Class::DeploymentHandler/VERSION SET>, and last is the
654 direction of the changegrade, be it 'up' or 'down'.
656 =method _read_sql_file
658 $dm->_read_sql_file('foo.sql')
660 Reads a sql file and returns lines in an C<ArrayRef>. Strips out comments,
661 transactions, and blank lines.