X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?p=dbsrgits%2FDBIx-Class-DeploymentHandler.git;a=blobdiff_plain;f=lib%2FDBIx%2FClass%2FDeploymentHandler.pm;h=1fd2038e7e5ae890d4bdca4768f6ed8905b68ea2;hp=dce3bcdde20aeec3696fdd33b974bbd361608493;hb=f7e215c9d2af2471f4586336fb7ed1ae3725be07;hpb=9e1c29c23930ad1f797906cecf671bb472f975ec diff --git a/lib/DBIx/Class/DeploymentHandler.pm b/lib/DBIx/Class/DeploymentHandler.pm index dce3bcd..1fd2038 100644 --- a/lib/DBIx/Class/DeploymentHandler.pm +++ b/lib/DBIx/Class/DeploymentHandler.pm @@ -1,474 +1,179 @@ package DBIx::Class::DeploymentHandler; +# ABSTRACT: Extensible DBIx::Class deployment + use Moose; -use Method::Signatures::Simple; -require DBIx::Class::Schema; # loaded for type constraint -require DBIx::Class::Storage; # loaded for type constraint -require DBIx::Class::ResultSet; # loaded for type constraint -use Carp::Clan '^DBIx::Class::DeploymentHandler'; -use SQL::Translator; -require SQL::Translator::Diff; -use Try::Tiny; - -BEGIN { - use Moose::Util::TypeConstraints; - subtype 'DBIx::Class::DeploymentHandler::Databases' - => as 'ArrayRef[Str]'; - - coerce 'DBIx::Class::DeploymentHandler::Databases' - => from 'Str' - => via { [$_] }; - no Moose::Util::TypeConstraints; + +extends 'DBIx::Class::DeploymentHandler::Dad'; +# a single with would be better, but we can't do that +# see: http://rt.cpan.org/Public/Bug/Display.html?id=46347 +with 'DBIx::Class::DeploymentHandler::WithSqltDeployMethod', + 'DBIx::Class::DeploymentHandler::WithMonotonicVersions', + 'DBIx::Class::DeploymentHandler::WithStandardVersionStorage'; +with 'DBIx::Class::DeploymentHandler::WithReasonableDefaults'; + +sub prepare_version_storage_install { + my $self = shift; + + $self->prepare_resultsource_install( + $self->version_storage->version_rs->result_source + ); } -has schema => ( - isa => 'DBIx::Class::Schema', - is => 'ro', - required => 1, - handles => [qw( ddl_filename schema_version )], -); - -has upgrade_directory => ( - isa => 'Str', - is => 'ro', - required => 1, - default => 'sql', -); - -has backup_directory => ( - isa => 'Str', - is => 'ro', -); - -has storage => ( - isa => 'DBIx::Class::Storage', - is => 'ro', - lazy_build => 1, -); - -method _build_storage { - my $s = $self->schema->storage; - $s->_determine_driver; - $s +sub install_version_storage { + my $self = shift; + + $self->install_resultsource( + $self->version_storage->version_rs->result_source + ); } -has _filedata => ( - isa => 'ArrayRef[Str]', - is => 'rw', -); - -has do_backup => ( - isa => 'Bool', - is => 'ro', - default => undef, -); - -has do_diff_on_init => ( - isa => 'Bool', - is => 'ro', - default => undef, -); - -has version_rs => ( - isa => 'DBIx::Class::ResultSet', - is => 'ro', - lazy_build => 1, - handles => [qw( is_installed db_version )], -); - -method _build_version_rs { - $self->schema->set_us_up_the_bomb; - $self->schema->resultset('__VERSION') +sub prepare_install { + $_[0]->prepare_deploy; + $_[0]->prepare_version_storage_install; } -has databases => ( - coerce => 1, - isa => 'DBIx::Class::DeploymentHandler::Databases', - is => 'ro', - default => sub { [qw( MySQL SQLite PostgreSQL )] }, -); - -has sqltargs => ( - isa => 'HashRef', - is => 'ro', - default => sub { {} }, -); - -method deployment_statements { - my $dir = $self->upgrade_directory; - my $schema = $self->schema; - my $type = $self->storage->sqlt_type; - my $sqltargs = $self->sqltargs; - my $version = $self->schema_version || '1.x'; - - my $filename = $self->ddl_filename($type, $version, $dir); - if(-f $filename) { - my $file; - open $file, q(<), $filename - or carp "Can't open $filename ($!)"; - my @rows = <$file>; - close $file; - return join '', @rows; - } - - # sources needs to be a parser arg, but for simplicty allow at top level - # coming in - $sqltargs->{parser_args}{sources} = delete $sqltargs->{sources} - if exists $sqltargs->{sources}; - - my $tr = SQL::Translator->new( - producer => "SQL::Translator::Producer::${type}", - %$sqltargs, - parser => 'SQL::Translator::Parser::DBIx::Class', - data => $schema, - ); +__PACKAGE__->meta->make_immutable; - my @ret; - my $wa = wantarray; - if ($wa) { - @ret = $tr->translate; - } - else { - $ret[0] = $tr->translate; - } +1; - $schema->throw_exception( 'Unable to produce deployment statements: ' . $tr->error) - unless (@ret && defined $ret[0]); +#vim: ts=2 sw=2 expandtab - return $wa ? @ret : $ret[0]; -} +__END__ -method deploy { - my $schema = $self->schema; - my $type = undef; - my $sqltargs = $self->sqltargs; - my $dir = $self->upgrade_directory; - my $storage = $self->storage; - - my $deploy = sub { - my $line = shift; - return if(!$line || $line =~ /^--|^BEGIN TRANSACTION|^COMMIT|^\s+$/); - $storage->_query_start($line); - try { - # do a dbh_do cycle here, as we need some error checking in - # place (even though we will ignore errors) - $storage->dbh_do (sub { $_[1]->do($line) }); - } - catch { - carp "$_ (running '${line}')" - } - $storage->_query_end($line); - }; - my @statements = $self->deployment_statements(); - if (@statements > 1) { - foreach my $statement (@statements) { - $deploy->( $statement ); - } - } - elsif (@statements == 1) { - foreach my $line ( split(";\n", $statements[0])) { - $deploy->( $line ); - } - } -} +=head1 SYNOPSIS -method backup { $self->storage->backup($self->backup_directory) } + use aliased 'DBIx::Class::DeploymentHandler' => 'DH'; + my $s = My::Schema->connect(...); -method install($new_version) { - carp 'Install not possible as versions table already exists in database' - if $self->is_installed; + my $dh = DH->new({ + schema => $s, + databases => 'SQLite', + sqltargs => { add_drop_table => 0 }, + }); - $new_version ||= $self->schema_version; + $dh->prepare_install; - if ($new_version) { - $self->deploy(); + $dh->install; - $self->version_rs->create({ - version => $new_version, - # ddl => $ddl, - # upgrade_sql => $upgrade_sql, - }); - } -} +or for upgrades: -method create_upgrade_path { } + use aliased 'DBIx::Class::DeploymentHandler' => 'DH'; + my $s = My::Schema->connect(...); -method ordered_schema_versions { undef } + my $dh = DH->new({ + schema => $s, + databases => 'SQLite', + sqltargs => { add_drop_table => 0 }, + }); -method upgrade { - my $db_version = $self->db_version; - my $schema_version = $self->schema_version; + $dh->prepare_upgrade(1, 2); - unless ($db_version) { - # croak? - carp 'Upgrade not possible as database is unversioned. Please call install first.'; - return; - } + $dh->upgrade; - if ( $db_version eq $schema_version ) { - # croak? - carp "Upgrade not necessary\n"; - return; - } +=head1 DESCRIPTION - my @version_list = $self->ordered_schema_versions || - ( $db_version, $schema_version ); +C is, as it's name suggests, a tool for +deploying and upgrading databases with L. It is designed to be +much more flexible than L, hence the use of +L and lots of roles. - # remove all versions in list above the required version - while ( @version_list && ( $version_list[-1] ne $schema_version ) ) { - pop @version_list; - } +C itself is just a recommended set of roles +that we think will not only work well for everyone, but will also yeild the +best overall mileage. Each role it uses has it's own nuances and +documentation, so I won't describe all of them here, but here are a few of the +major benefits over how L worked (and +L tries to maintain compatibility +with): - # remove all versions in list below the current version - while ( @version_list && ( $version_list[0] ne $db_version ) ) { - shift @version_list; - } +=over - # check we have an appropriate list of versions - die if @version_list < 2; +=item * - # do sets of upgrade - while ( @version_list >= 2 ) { - $self->upgrade_single_step( $version_list[0], $version_list[1] ); - shift @version_list; - } -} +Downgrades in addition to upgrades. -method upgrade_single_step($db_version, $target_version) { - if ($db_version eq $target_version) { - # croak? - carp "Upgrade not necessary\n"; - return; - } - - my $upgrade_file = $self->ddl_filename( - $self->storage->sqlt_type, - $target_version, - $self->upgrade_directory, - $db_version, - ); +=item * - $self->create_upgrade_path({ upgrade_file => $upgrade_file }); +Multiple sql files files per upgrade/downgrade/install. - unless (-f $upgrade_file) { - # croak? - carp "Upgrade not possible, no upgrade file found ($upgrade_file), please create one\n"; - return; - } +=item * - carp "DB version ($db_version) is lower than the schema version (".$self->schema_version."). Attempting upgrade.\n"; +Perl scripts allowed for upgrade/downgrade/install. - $self->_filedata($self->_read_sql_file($upgrade_file)); # I don't like this --fREW 2010-02-22 - $self->backup if $self->do_backup; - $self->schema->txn_do(sub { $self->do_upgrade }); +=item * - $self->version_rs->create({ - version => $target_version, - # ddl => $ddl, - # upgrade_sql => $upgrade_sql, - }); -} +Just one set of files needed for upgrade, unlike before where one might need +to generate C, which is just silly. -method create_install_ddl { - my $schema = $self->schema; - my $databases = $self->databases; - my $dir = $self->upgrade_directory; - my $sqltargs = $self->sqltargs; - unless( -d $dir ) { - carp "Upgrade directory $dir does not exist, using ./\n"; - $dir = "./"; - } - - my $version = $schema->schema_version || '1.x'; - my $schema_version = $schema->schema_version || '1.x'; - $version ||= $schema_version; - - $sqltargs = { - add_drop_table => 1, - ignore_constraint_names => 1, - ignore_index_names => 1, - %{$sqltargs || {}} - }; - - my $sqlt = SQL::Translator->new( $sqltargs ); - - $sqlt->parser('SQL::Translator::Parser::DBIx::Class'); - my $sqlt_schema = $sqlt->translate({ data => $schema }) - or $self->throw_exception ($sqlt->error); - - foreach my $db (@$databases) { - $sqlt->reset; - $sqlt->{schema} = $sqlt_schema; - $sqlt->producer($db); - - my $filename = $self->ddl_filename($db, $version, $dir); - if (-e $filename && ($version eq $schema_version )) { - # if we are dumping the current version, overwrite the DDL - carp "Overwriting existing DDL file - $filename"; - unlink $filename; - } - - my $output = $sqlt->translate; - if(!$output) { - carp("Failed to translate to $db, skipping. (" . $sqlt->error . ")"); - next; - } - my $file; - unless( open $file, q(>), $filename ) { - $self->throw_exception("Can't open $filename for writing ($!)"); - next; - } - print {$file} $output; - close $file; - } -} +=item * -method create_update_ddl($version, $preversion) { - my $schema = $self->schema; - my $databases = $self->databases; - my $dir = $self->upgrade_directory; - my $sqltargs = $self->sqltargs; - - unless( -d $dir ) { - carp "Upgrade directory $dir does not exist, using ./\n"; - $dir = "./"; - } - - my $schema_version = $schema->schema_version || '1.x'; - $version ||= $schema_version; - - $sqltargs = { - add_drop_table => 1, - ignore_constraint_names => 1, - ignore_index_names => 1, - %{$sqltargs} - }; - - my $sqlt = SQL::Translator->new( $sqltargs ); - - $sqlt->parser('SQL::Translator::Parser::DBIx::Class'); - my $sqlt_schema = $sqlt->translate({ data => $schema }) - or $self->throw_exception ($sqlt->error); - - foreach my $db (@$databases) { - $sqlt->reset; - $sqlt->{schema} = $sqlt_schema; - $sqlt->producer($db); - - my $prefilename = $self->ddl_filename($db, $preversion, $dir); - unless(-e $prefilename) { - carp("No previous schema file found ($prefilename)"); - next; - } - - my $diff_file = $self->ddl_filename($db, $version, $dir, $preversion); - if(-e $diff_file) { - carp("Overwriting existing diff file - $diff_file"); - unlink $diff_file; - } - - my $source_schema; - { - my $t = SQL::Translator->new({ - %{$sqltargs}, - debug => 0, - trace => 0, - }); - - $t->parser( $db ) # could this really throw an exception? - or $self->throw_exception ($t->error); - - my $out = $t->translate( $prefilename ) - or $self->throw_exception ($t->error); - - $source_schema = $t->schema; - - $source_schema->name( $prefilename ) - unless $source_schema->name; - } - - # The "new" style of producers have sane normalization and can support - # diffing a SQL file against a DBIC->SQLT schema. Old style ones don't - # And we have to diff parsed SQL against parsed SQL. - my $dest_schema = $sqlt_schema; - - unless ( "SQL::Translator::Producer::$db"->can('preprocess_schema') ) { - my $t = SQL::Translator->new({ - %{$sqltargs}, - debug => 0, - trace => 0, - }); - - $t->parser( $db ) # could this really throw an exception? - or $self->throw_exception ($t->error); - - my $filename = $self->ddl_filename($db, $version, $dir); - my $out = $t->translate( $filename ) - or $self->throw_exception ($t->error); - - $dest_schema = $t->schema; - - $dest_schema->name( $filename ) - unless $dest_schema->name; - } - - my $diff = SQL::Translator::Diff::schema_diff( - $source_schema, $db, - $dest_schema, $db, - $sqltargs - ); - my $file; - unless(open $file, q(>), $diff_file) { - $self->throw_exception("Can't write to $diff_file ($!)"); - next; - } - print {$file} $diff; - close $file; - } -} +And much, much more! -method create_ddl_dir($version, $preversion) { - $self->create_install_ddl; - $self->create_update_ddl($version, $preversion) if $preversion; -} +=back -method do_upgrade { $self->run_upgrade(qr/.*?/) } +That's really just a taste of some of the differences. Check out each role for +all the details. -method run_upgrade($stm) { - return unless $self->_filedata; - my @statements = grep { $_ =~ $stm } @{$self->_filedata}; +=head1 WHERE IS ALL THE DOC?! - for (@statements) { - $self->storage->debugobj->query_start($_) if $self->storage->debug; - $self->apply_statement($_); - $self->storage->debugobj->query_end($_) if $self->storage->debug; - } -} +C extends +L, so that's probably the first place to +look when you are trying to figure out how everything works. -method apply_statement($statement) { - # croak? - $self->storage->dbh->do($_) or carp "SQL was: $_" -} +Next would be to look at all the roles that fill in the blanks that +L expects to be filled. They would be +L, +L, +L, and +L. -method _read_sql_file($file) { - return unless $file; +=method prepare_version_storage_install - open my $fh, '<', $file or carp("Can't open upgrade file, $file ($!)"); - my @data = split /\n/, join '', <$fh>; - close $fh; + $dh->prepare_version_storage_install - @data = grep { - $_ && - !/^--/ && - !/^(BEGIN|BEGIN TRANSACTION|COMMIT)/m - } split /;/, - join '', @data; +Creates the needed C<.sql> file to install the version storage and not the rest +of the tables - return \@data; -} +=method prepare_install -1; + $dh->prepare_install -__END__ +First prepare all the tables to be installed and the prepare just the version +storage + +=method install_version_storage + + $dh->install_version_storage + +Install the version storage and not the rest of the tables + +=head1 THIS SUCKS + +You started your project and weren't using C? +Lucky for you I had you in mind when I wrote this doc. + +First off, you'll want to just install the C: + + my $s = My::Schema->connect(...); + my $dh = DBIx::Class::DeploymentHandler({ schema => $s }); + + $dh->prepare_version_storage_install; + $dh->install_version_storage; + +Then set your database version: + + $dh->add_database_version({ version => $s->version }); + +Now you should be able to use C like normal! + +=head1 DONATIONS + +If you'd like to thank me for the work I've done on this module, don't give me +a donation. I spend a lot of free time creating free software, but I do it +because I love it. -vim: ts=2,sw=2,expandtab +Instead, consider donating to someone who might actually need it. Obviously +you should do research when donating to a charity, so don't just take my word +on this. I like Children's Survival Fund: +L, but there are a host of other +charities that can do much more good than I will with your money.