[dbsrgits/DBIx-Class-DeploymentHandler.git] / lib / DBIx / Class / DeploymentHandler / SqltDeployMethod.pm

package DBIx::Class::DeploymentHandler::SqltDeployMethod;
use Moose;
use Method::Signatures::Simple;
use Try::Tiny;
use SQL::Translator;
require SQL::Translator::Diff;
require DBIx::Class::Storage;   # loaded for type constraint

use Carp 'carp';

has storage => (
  isa        => 'DBIx::Class::Storage',
  is         => 'ro',
  lazy_build => 1,
);

method _build_storage {
  my $s = $self->schema->storage;
  $s->_determine_driver;
  $s
}

has backup_directory => (
  isa => 'Str',
  is  => 'ro',
);

has do_backup => (
  isa     => 'Bool',
  is      => 'ro',
  default => undef,
);

has sqltargs => (
  isa => 'HashRef',
  is  => 'ro',
  default => sub { {} },
);
has upgrade_directory => (
  isa      => 'Str',
  is       => 'ro',
  required => 1,
  default  => 'sql',
);

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')
}

has databases => (
  coerce  => 1,
  isa     => 'DBIx::Class::DeploymentHandler::Databases',
  is      => 'ro',
  default => sub { [qw( MySQL SQLite PostgreSQL )] },
);

has schema => (
  isa      => 'DBIx::Class::Schema',
  is       => 'ro',
  required => 1,
  handles => [qw( schema_version )],
);

has _filedata => (
  isa => 'ArrayRef[Str]',
  is  => 'rw',
);

method _ddl_filename($type, $versions, $dir) {
  my $filename = ref $self->schema;
  $filename =~ s/::/-/g;

  $filename = File::Spec->catfile(
    $dir, "$filename-" . join( q(-), @{$versions} ) . "-$type.sql"
  );

  return $filename;
}

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,
  );

  my @ret;
  my $wa = wantarray;
  if ($wa) {
    @ret = $tr->translate;
  }
  else {
    $ret[0] = $tr->translate;
  }

  $schema->throw_exception( 'Unable to produce deployment statements: ' . $tr->error)
    unless (@ret && defined $ret[0]);

  return $wa ? @ret : $ret[0];
}

method _deploy {
  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 );
    }
  }
}

method prepare_install {
  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;
  }
}

method prepare_update($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, [ $preversion, $version ], $dir );
    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;
  }
}

method _read_sql_file($file) {
  return unless $file;

  open my $fh, '<', $file or carp("Can't open upgrade file, $file ($!)");
  my @data = split /\n/, join '', <$fh>;
  close $fh;

  @data = grep {
    $_ &&
    !/^--/ &&
    !/^(BEGIN|BEGIN TRANSACTION|COMMIT)/m
  } split /;/,
    join '', @data;

  return \@data;
}

method _upgrade_single_step {
  my @version_set = @{ shift @_ };
  my $db_version = $self->db_version;
  my $upgrade_file = $self->_ddl_filename(
    $self->storage->sqlt_type,
    \@version_set,
    $self->upgrade_directory,
  );

  unless (-f $upgrade_file) {
    # croak?
    carp "Upgrade not possible, no upgrade file found ($upgrade_file), please create one\n";
    return;
  }

  carp "DB version ($db_version) is lower than the schema version (".$self->schema_version."). Attempting upgrade.\n";

  $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 });

  $self->version_rs->create({
    version     => $version_set[-1],
    # ddl         => $ddl,
    # upgrade_sql => $upgrade_sql,
  });
}

method _do_upgrade { $self->_run_upgrade(qr/.*?/) }

method _run_upgrade($stm) {
  return unless $self->_filedata;
  my @statements = grep { $_ =~ $stm } @{$self->_filedata};

  for (@statements) {
    $self->storage->debugobj->query_start($_) if $self->storage->debug;
    $self->_apply_statement($_);
    $self->storage->debugobj->query_end($_) if $self->storage->debug;
  }
}

method _apply_statement($statement) {
  # croak?
  $self->storage->dbh->do($_) or carp "SQL was: $_"
}

method backup { $self->storage->backup($self->backup_directory) }

__PACKAGE__->meta->make_immutable;

1;

__END__

vim: ts=2 sw=2 expandtab
Commit	Line	Data
2e68a8e1	1	package DBIx::Class::DeploymentHandler::SqltDeployMethod;
334bced5	2	use Moose;
2e68a8e1	3	use Method::Signatures::Simple;
7f50d101	4	use Try::Tiny;
d23c7c77	5	use SQL::Translator;
	6	require SQL::Translator::Diff;
	7	require DBIx::Class::Storage; # loaded for type constraint
2e68a8e1	8
	9	use Carp 'carp';
	10
334bced5	11	has storage => (
	12	isa => 'DBIx::Class::Storage',
	13	is => 'ro',
	14	lazy_build => 1,
	15	);
	16
2eaf903b	17	method _build_storage {
	18	my $s = $self->schema->storage;
	19	$s->_determine_driver;
	20	$s
	21	}
	22
334bced5	23	has backup_directory => (
	24	isa => 'Str',
	25	is => 'ro',
	26	);
	27
	28	has do_backup => (
	29	isa => 'Bool',
	30	is => 'ro',
	31	default => undef,
	32	);
	33
	34	has sqltargs => (
	35	isa => 'HashRef',
	36	is => 'ro',
	37	default => sub { {} },
	38	);
	39	has upgrade_directory => (
	40	isa => 'Str',
	41	is => 'ro',
	42	required => 1,
	43	default => 'sql',
	44	);
	45
	46	has version_rs => (
	47	isa => 'DBIx::Class::ResultSet',
	48	is => 'ro',
	49	lazy_build => 1,
	50	handles => [qw( is_installed db_version )],
	51	);
	52
	53	method _build_version_rs {
	54	$self->schema->set_us_up_the_bomb;
	55	$self->schema->resultset('__VERSION')
	56	}
	57
	58	has databases => (
	59	coerce => 1,
	60	isa => 'DBIx::Class::DeploymentHandler::Databases',
	61	is => 'ro',
	62	default => sub { [qw( MySQL SQLite PostgreSQL )] },
	63	);
	64
	65	has schema => (
	66	isa => 'DBIx::Class::Schema',
	67	is => 'ro',
	68	required => 1,
24f4524b	69	handles => [qw( schema_version )],
334bced5	70	);
	71
	72	has _filedata => (
	73	isa => 'ArrayRef[Str]',
	74	is => 'rw',
	75	);
	76
8a7847f1	77	method _ddl_filename($type, $versions, $dir) {
a912450b	78	my $filename = ref $self->schema;
24f4524b	79	$filename =~ s/::/-/g;
	80
	81	$filename = File::Spec->catfile(
	82	$dir, "$filename-" . join( q(-), @{$versions} ) . "-$type.sql"
	83	);
	84
	85	return $filename;
	86	}
	87
8a7847f1	88	method _deployment_statements {
2e68a8e1	89	my $dir = $self->upgrade_directory;
	90	my $schema = $self->schema;
	91	my $type = $self->storage->sqlt_type;
	92	my $sqltargs = $self->sqltargs;
	93	my $version = $self->schema_version \|\| '1.x';
	94
8a7847f1	95	my $filename = $self->_ddl_filename($type, [ $version ], $dir);
2e68a8e1	96	if(-f $filename) {
	97	my $file;
	98	open $file, q(<), $filename
	99	or carp "Can't open $filename ($!)";
	100	my @rows = <$file>;
	101	close $file;
	102	return join '', @rows;
	103	}
	104
	105	# sources needs to be a parser arg, but for simplicty allow at top level
	106	# coming in
	107	$sqltargs->{parser_args}{sources} = delete $sqltargs->{sources}
	108	if exists $sqltargs->{sources};
	109
	110	my $tr = SQL::Translator->new(
	111	producer => "SQL::Translator::Producer::${type}",
	112	%$sqltargs,
	113	parser => 'SQL::Translator::Parser::DBIx::Class',
	114	data => $schema,
	115	);
	116
	117	my @ret;
	118	my $wa = wantarray;
	119	if ($wa) {
	120	@ret = $tr->translate;
	121	}
	122	else {
	123	$ret[0] = $tr->translate;
	124	}
	125
	126	$schema->throw_exception( 'Unable to produce deployment statements: ' . $tr->error)
	127	unless (@ret && defined $ret[0]);
	128
	129	return $wa ? @ret : $ret[0];
	130	}
	131
8a7847f1	132	method _deploy {
2e68a8e1	133	my $storage = $self->storage;
	134
	135	my $deploy = sub {
	136	my $line = shift;
	137	return if(!$line \|\| $line =~ /^--\|^BEGIN TRANSACTION\|^COMMIT\|^\s+$/);
	138	$storage->_query_start($line);
	139	try {
	140	# do a dbh_do cycle here, as we need some error checking in
	141	# place (even though we will ignore errors)
	142	$storage->dbh_do (sub { $_[1]->do($line) });
	143	}
	144	catch {
	145	carp "$_ (running '${line}')"
	146	}
	147	$storage->_query_end($line);
	148	};
8a7847f1	149	my @statements = $self->_deployment_statements();
2e68a8e1	150	if (@statements > 1) {
	151	foreach my $statement (@statements) {
	152	$deploy->( $statement );
	153	}
	154	}
	155	elsif (@statements == 1) {
	156	foreach my $line ( split(";\n", $statements[0])) {
	157	$deploy->( $line );
	158	}
	159	}
	160	}
	161
a912450b	162	method prepare_install {
2e68a8e1	163	my $schema = $self->schema;
	164	my $databases = $self->databases;
	165	my $dir = $self->upgrade_directory;
	166	my $sqltargs = $self->sqltargs;
	167	unless( -d $dir ) {
	168	carp "Upgrade directory $dir does not exist, using ./\n";
	169	$dir = "./";
	170	}
	171
	172	my $version = $schema->schema_version \|\| '1.x';
	173	my $schema_version = $schema->schema_version \|\| '1.x';
	174	$version \|\|= $schema_version;
	175
	176	$sqltargs = {
	177	add_drop_table => 1,
	178	ignore_constraint_names => 1,
	179	ignore_index_names => 1,
	180	%{$sqltargs \|\| {}}
	181	};
	182
	183	my $sqlt = SQL::Translator->new( $sqltargs );
	184
	185	$sqlt->parser('SQL::Translator::Parser::DBIx::Class');
	186	my $sqlt_schema = $sqlt->translate({ data => $schema })
	187	or $self->throw_exception ($sqlt->error);
	188
	189	foreach my $db (@$databases) {
	190	$sqlt->reset;
	191	$sqlt->{schema} = $sqlt_schema;
	192	$sqlt->producer($db);
	193
8a7847f1	194	my $filename = $self->_ddl_filename($db, [ $version ], $dir);
2e68a8e1	195	if (-e $filename && ($version eq $schema_version )) {
	196	# if we are dumping the current version, overwrite the DDL
	197	carp "Overwriting existing DDL file - $filename";
	198	unlink $filename;
	199	}
	200
	201	my $output = $sqlt->translate;
	202	if(!$output) {
	203	carp("Failed to translate to $db, skipping. (" . $sqlt->error . ")");
	204	next;
	205	}
	206	my $file;
	207	unless( open $file, q(>), $filename ) {
	208	$self->throw_exception("Can't open $filename for writing ($!)");
	209	next;
	210	}
	211	print {$file} $output;
	212	close $file;
	213	}
	214	}
	215
199410d3	216	method prepare_update($version, $preversion) {
2e68a8e1	217	my $schema = $self->schema;
	218	my $databases = $self->databases;
	219	my $dir = $self->upgrade_directory;
	220	my $sqltargs = $self->sqltargs;
	221
	222	unless( -d $dir ) {
	223	carp "Upgrade directory $dir does not exist, using ./\n";
	224	$dir = "./";
	225	}
	226
	227	my $schema_version = $schema->schema_version \|\| '1.x';
	228	$version \|\|= $schema_version;
	229
	230	$sqltargs = {
	231	add_drop_table => 1,
	232	ignore_constraint_names => 1,
	233	ignore_index_names => 1,
	234	%{$sqltargs}
	235	};
	236
	237	my $sqlt = SQL::Translator->new( $sqltargs );
	238
	239	$sqlt->parser('SQL::Translator::Parser::DBIx::Class');
	240	my $sqlt_schema = $sqlt->translate({ data => $schema })
	241	or $self->throw_exception ($sqlt->error);
	242
	243	foreach my $db (@$databases) {
	244	$sqlt->reset;
	245	$sqlt->{schema} = $sqlt_schema;
	246	$sqlt->producer($db);
	247
8a7847f1	248	my $prefilename = $self->_ddl_filename($db, [ $preversion ], $dir);
2e68a8e1	249	unless(-e $prefilename) {
	250	carp("No previous schema file found ($prefilename)");
	251	next;
	252	}
	253
8a7847f1	254	my $diff_file = $self->_ddl_filename($db, [ $preversion, $version ], $dir );
2e68a8e1	255	if(-e $diff_file) {
	256	carp("Overwriting existing diff file - $diff_file");
	257	unlink $diff_file;
	258	}
	259
	260	my $source_schema;
	261	{
	262	my $t = SQL::Translator->new({
	263	%{$sqltargs},
	264	debug => 0,
	265	trace => 0,
	266	});
	267
	268	$t->parser( $db ) # could this really throw an exception?
	269	or $self->throw_exception ($t->error);
	270
	271	my $out = $t->translate( $prefilename )
	272	or $self->throw_exception ($t->error);
	273
	274	$source_schema = $t->schema;
	275
	276	$source_schema->name( $prefilename )
	277	unless $source_schema->name;
	278	}
	279
	280	# The "new" style of producers have sane normalization and can support
	281	# diffing a SQL file against a DBIC->SQLT schema. Old style ones don't
	282	# And we have to diff parsed SQL against parsed SQL.
	283	my $dest_schema = $sqlt_schema;
	284
	285	unless ( "SQL::Translator::Producer::$db"->can('preprocess_schema') ) {
	286	my $t = SQL::Translator->new({
	287	%{$sqltargs},
	288	debug => 0,
	289	trace => 0,
	290	});
	291
	292	$t->parser( $db ) # could this really throw an exception?
	293	or $self->throw_exception ($t->error);
	294
8a7847f1	295	my $filename = $self->_ddl_filename($db, [ $version ], $dir);
2e68a8e1	296	my $out = $t->translate( $filename )
	297	or $self->throw_exception ($t->error);
	298
	299	$dest_schema = $t->schema;
	300
	301	$dest_schema->name( $filename )
	302	unless $dest_schema->name;
	303	}
	304
	305	my $diff = SQL::Translator::Diff::schema_diff(
	306	$source_schema, $db,
	307	$dest_schema, $db,
	308	$sqltargs
	309	);
	310	my $file;
	311	unless(open $file, q(>), $diff_file) {
	312	$self->throw_exception("Can't write to $diff_file ($!)");
	313	next;
	314	}
	315	print {$file} $diff;
	316	close $file;
	317	}
	318	}
	319
334bced5	320	method _read_sql_file($file) {
	321	return unless $file;
	322
	323	open my $fh, '<', $file or carp("Can't open upgrade file, $file ($!)");
	324	my @data = split /\n/, join '', <$fh>;
	325	close $fh;
	326
	327	@data = grep {
	328	$_ &&
	329	!/^--/ &&
	330	!/^(BEGIN\|BEGIN TRANSACTION\|COMMIT)/m
	331	} split /;/,
	332	join '', @data;
	333
	334	return \@data;
	335	}
	336
8a7847f1	337	method _upgrade_single_step {
24f4524b	338	my @version_set = @{ shift @_ };
24f4524b	339	my $db_version = $self->db_version;
8a7847f1	340	my $upgrade_file = $self->_ddl_filename(
334bced5	341	$self->storage->sqlt_type,
24f4524b	342	\@version_set,
334bced5	343	$self->upgrade_directory,
334bced5	344	);
334bced5	345
334bced5	346	unless (-f $upgrade_file) {
	347	# croak?
	348	carp "Upgrade not possible, no upgrade file found ($upgrade_file), please create one\n";
	349	return;
	350	}
	351
	352	carp "DB version ($db_version) is lower than the schema version (".$self->schema_version."). Attempting upgrade.\n";
	353
	354	$self->_filedata($self->_read_sql_file($upgrade_file)); # I don't like this --fREW 2010-02-22
	355	$self->backup if $self->do_backup;
8a7847f1	356	$self->schema->txn_do(sub { $self->_do_upgrade });
334bced5	357
334bced5	358	$self->version_rs->create({
24f4524b	359	version => $version_set[-1],
334bced5	360	# ddl => $ddl,
	361	# upgrade_sql => $upgrade_sql,
	362	});
	363	}
	364
8a7847f1	365	method _do_upgrade { $self->_run_upgrade(qr/.*?/) }
334bced5	366
8a7847f1	367	method _run_upgrade($stm) {
334bced5	368	return unless $self->_filedata;
	369	my @statements = grep { $_ =~ $stm } @{$self->_filedata};
	370
	371	for (@statements) {
	372	$self->storage->debugobj->query_start($_) if $self->storage->debug;
8a7847f1	373	$self->_apply_statement($_);
334bced5	374	$self->storage->debugobj->query_end($_) if $self->storage->debug;
	375	}
	376	}
	377
8a7847f1	378	method _apply_statement($statement) {
334bced5	379	# croak?
	380	$self->storage->dbh->do($_) or carp "SQL was: $_"
	381	}
	382
	383	method backup { $self->storage->backup($self->backup_directory) }
	384
	385	__PACKAGE__->meta->make_immutable;
e051bb00	386
2e68a8e1	387	1;
e051bb00	388
	389	__END__
	390
2eaf903b	391	vim: ts=2 sw=2 expandtab