PostgreSQL: add support for TRIGGERs and FUNCTIONs

lib/SQL/Translator/Diff.pm

@@ -40,11 +40,47 @@ has table_diff_hash => (
   lazy    => 1,
   default => quote_sub '{}',
 );
+has triggers_to_drop => (
+  is => 'rw',
+  lazy => 1,
+  default => quote_sub '[]',
+);
+has triggers_to_modify => (
+  is => 'rw',
+  lazy => 1,
+  default => quote_sub '[]',
+);
+has triggers_to_create => (
+  is => 'rw',
+  lazy => 1,
+  default => quote_sub '[]',
+);
+has procedures_to_drop => (
+  is => 'rw',
+  lazy => 1,
+  default => quote_sub '[]',
+);
+has procedures_to_modify => (
+  is => 'rw',
+  lazy => 1,
+  default => quote_sub '[]',
+);
+has procedures_to_create => (
+  is => 'rw',
+  lazy => 1,
+  default => quote_sub '[]',
+);
 
 my @diff_arrays = qw/
     tables_to_drop
     tables_to_create
-    /;
+    triggers_to_drop
+    triggers_to_modify
+    triggers_to_create
+    procedures_to_drop
+    procedures_to_modify
+    procedures_to_create
+/;
 
 my @diff_hash_keys = qw/
     constraints_to_create
@@ -115,10 +151,11 @@ sub compute_differences {
   }
 
   my %src_tables_checked = ();
-  my @tar_tables         = sort { $a->name cmp $b->name } $target_schema->get_tables;
+  my %src_tables_deleted = ();
+  my @tar_tables         = sort { $a->qualified_name cmp $b->qualified_name } $target_schema->get_tables;
   ## do original/source tables exist in target?
   for my $tar_table (@tar_tables) {
-    my $tar_table_name = $tar_table->name;
+    my $tar_table_name = $tar_table->qualified_name;
 
     my $src_table;
 
@@ -143,7 +180,7 @@ sub compute_differences {
       next;
     }
 
-    my $src_table_name = $src_table->name;
+    my $src_table_name = $src_table->qualified_name;
     $src_table_name = lc $src_table_name if $self->case_insensitive;
     $src_tables_checked{$src_table_name} = 1;
 
@@ -158,12 +195,75 @@ sub compute_differences {
   }    # end of target_schema->get_tables loop
 
   for my $src_table ($source_schema->get_tables) {
-    my $src_table_name = $src_table->name;
+    my $src_table_name = $src_table->qualified_name;
 
     $src_table_name = lc $src_table_name if $self->case_insensitive;
 
-    push @{ $self->tables_to_drop }, $src_table
-        unless $src_tables_checked{$src_table_name};
+    next if $src_tables_checked{$src_table_name};
+    push @{ $self->tables_to_drop}, $src_table;
+    $src_tables_deleted{$src_table_name} = 1;
+  }
+
+  my %src_triggers_checked = ();
+  my @tgt_triggers = sort { $a->name cmp $b->name } $target_schema->get_triggers;
+  for my $tgt_trigger ( @tgt_triggers ) {
+    my $name = $tgt_trigger->name;
+
+    my $src_trigger = $source_schema->get_trigger( $name, $self->case_insensitive );
+
+    unless ( $src_trigger ) {
+      push @{$self->triggers_to_create}, $tgt_trigger;
+      next;
+    }
+
+    my $src_trigger_name = $src_trigger->name;
+    $src_trigger_name = lc $src_trigger_name if $self->case_insensitive;
+    $src_triggers_checked{$src_trigger_name} = 1;
+
+    # Compare trigger
+    push @{$self->triggers_to_modify}, $tgt_trigger
+      unless $src_trigger->equals( $tgt_trigger );
+  }
+
+  for my $src_trigger ( $source_schema->get_triggers ) {
+    my $name = $src_trigger->name;
+    $name = lc $name if $self->case_insensitive;
+
+    my $src_table_name = $src_trigger->on_table;
+    $src_table_name = lc $src_table_name if $self->case_insensitive;
+
+    push @{ $self->triggers_to_drop }, $src_trigger
+      unless $src_triggers_checked{$name} or $src_tables_deleted{$src_table_name};
+  }
+
+  my %src_procedures_checked = ();
+  my @tgt_procedures = sort { $a->name cmp $b->name } $target_schema->get_procedures;
+  for my $tgt_procedure ( @tgt_procedures ) {
+    my $name = $tgt_procedure->name;
+
+    my $src_procedure = $source_schema->get_procedure( $name, $self->case_insensitive );
+
+    unless ( $src_procedure ) {
+      push @{$self->procedures_to_create}, $tgt_procedure;
+      next;
+    }
+
+    my $src_procedure_name = $src_procedure->name;
+    $src_procedure_name = lc $src_procedure_name if $self->case_insensitive;
+    $src_procedures_checked{$src_procedure_name} = 1;
+
+    # Compare SQL in procedure declaration
+    next unless $src_procedure->sql ne $tgt_procedure->sql;
+    push @{$self->procedures_to_modify}, $tgt_procedure;
+  }
+
+  for my $src_procedure ( $source_schema->get_procedures ) {
+    my $name = $src_procedure->name;
+
+    $name = lc $name if $self->case_insensitive;
+
+    push @{ $self->procedures_to_drop}, $src_procedure
+      unless $src_procedures_checked{$name};
   }
 
   return $self;
@@ -280,6 +380,96 @@ sub produce_diff_sql {
         :                                 die "$producer_class cant drop_table";
   }
 
+  if (my @triggers = @{ $self->triggers_to_create } ) {
+    my $translator = SQL::Translator->new(
+      producer_type => $self->output_db,
+      add_drop_table => 0,
+      no_comments => 1,
+      # TODO: sort out options
+      %{ $self->producer_args }
+    );
+    $translator->producer_args->{no_transaction} = 1;
+    my $schema = $translator->schema;
+
+    $schema->add_trigger($_) for @triggers;
+
+    push @diffs,
+      # Remove begin/commit here, since we wrap everything in one.
+      grep { $_ !~ /^(?:COMMIT|START(?: TRANSACTION)?|BEGIN(?: TRANSACTION)?)/ } $producer_class->can('produce')->($translator);
+  }
+
+  if (my @triggers_to_drop = @{ $self->{triggers_to_drop} || []} ) {
+    my $meth = $producer_class->can('drop_trigger');
+
+    push @diffs, $meth ? ( map { $meth->($_, $self->producer_args) } @triggers_to_drop)
+                       : $self->ignore_missing_methods
+                       ? "-- $producer_class cant drop_trigger"
+                       : die "$producer_class cant drop_trigger";
+  }
+
+  if (my @triggers = @{ $self->triggers_to_modify } ) {
+    my $translator = SQL::Translator->new(
+      producer_type => $self->output_db,
+      add_drop_table => 1,
+      no_comments => 1,
+      # TODO: sort out options
+      %{ $self->producer_args }
+    );
+    $translator->producer_args->{no_transaction} = 1;
+    my $schema = $translator->schema;
+
+    $schema->add_trigger($_) for @triggers;
+
+    push @diffs,
+      # Remove begin/commit here, since we wrap everything in one.
+      grep { $_ !~ /^(?:COMMIT|START(?: TRANSACTION)?|BEGIN(?: TRANSACTION)?)/ } $producer_class->can('produce')->($translator);
+  }
+
+  if (my @procedures = @{ $self->procedures_to_create } ) {
+    my $translator = SQL::Translator->new(
+      producer_type => $self->output_db,
+      add_drop_table => 0,
+      no_comments => 1,
+      # TODO: sort out options
+      %{ $self->producer_args }
+    );
+    $translator->producer_args->{no_transaction} = 1;
+    my $schema = $translator->schema;
+
+    $schema->add_procedure($_) for @procedures;
+
+    push @diffs,
+      # Remove begin/commit here, since we wrap everything in one.
+      grep { $_ !~ /^(?:COMMIT|START(?: TRANSACTION)?|BEGIN(?: TRANSACTION)?)/ } $producer_class->can('produce')->($translator);
+  }
+
+  if (my @procedures_to_drop = @{ $self->{procedures_to_drop} || []} ) {
+    my $meth = $producer_class->can('drop_procedure');
+
+    push @diffs, $meth ? ( map { $meth->($_, $self->producer_args) } @procedures_to_drop)
+                       : $self->ignore_missing_methods
+                       ? "-- $producer_class cant drop_procedure"
+                       : die "$producer_class cant drop_procedure";
+  }
+
+  if (my @procedures_to_modify = @{ $self->{procedures_to_modify} || []} ) {
+    my $translator = SQL::Translator->new(
+      producer_type => $self->output_db,
+      add_drop_table => 1,
+      no_comments => 1,
+      # TODO: sort out options
+      %{ $self->producer_args }
+    );
+    $translator->producer_args->{no_transaction} = 1;
+    my $schema = $translator->schema;
+
+    $schema->add_procedure($_) for @procedures_to_modify;
+
+    push @diffs,
+      # Remove begin/commit here, since we wrap everything in one.
+      grep { $_ !~ /^(?:COMMIT|START(?: TRANSACTION)?|BEGIN(?: TRANSACTION)?)/ } $producer_class->can('produce')->($translator);
+  }
+
   if (@diffs) {
     unshift @diffs, "BEGIN";
     push @diffs, "\nCOMMIT";
@@ -375,7 +565,7 @@ sub diff_table_fields {
     if (my $old_name = $tar_table_field->extra->{renamed_from}) {
       my $src_table_field = $src_table->get_field($old_name, $self->case_insensitive);
       unless ($src_table_field) {
-        carp qq#Renamed column can't find old column "@{[$src_table->name]}.$old_name" for renamed column\n#;
+        carp qq#Renamed column can't find old column "@{[$src_table->qualified_name]}.$old_name" for renamed column\n#;
         delete $tar_table_field->extra->{renamed_from};
       } else {
         push @{ $self->table_diff_hash->{$tar_table}{fields_to_rename} }, [ $src_table_field, $tar_table_field ];

lib/SQL/Translator/Generator/DDL/SQLServer.pm

@@ -53,15 +53,15 @@ sub field_autoinc { ($_[1]->is_auto_increment ? 'IDENTITY' : ()) }
 
 sub primary_key_constraint {
   'CONSTRAINT '
-      . $_[0]->quote($_[1]->name || $_[1]->table->name . '_pk')
+      . $_[0]->quote($_[1]->name || $_[1]->table->qualified_name . '_pk')
       . ' PRIMARY KEY ('
       . join(', ', map $_[0]->quote($_), $_[1]->fields) . ')';
 }
 
 sub index {
   'CREATE INDEX '
-      . $_[0]->quote($_[1]->name || $_[1]->table->name . '_idx') . ' ON '
-      . $_[0]->quote($_[1]->table->name) . ' ('
+      . $_[0]->quote($_[1]->name || $_[1]->table->qualified_name . '_idx') . ' ON '
+      . $_[0]->quote($_[1]->table->qualified_name) . ' ('
       . join(', ', map $_[0]->quote($_), $_[1]->fields) . ');';
 }
 
@@ -76,15 +76,15 @@ sub unique_constraint_single {
 
 sub unique_constraint_name {
   my ($self, $constraint) = @_;
-  $self->quote($constraint->name || $constraint->table->name . '_uc');
+  $self->quote($constraint->name || $constraint->table->qualified_name . '_uc');
 }
 
 sub unique_constraint_multiple {
   my ($self, $constraint) = @_;
 
   'CREATE UNIQUE NONCLUSTERED INDEX '
       . $self->unique_constraint_name($constraint) . ' ON '
-      . $self->quote($constraint->table->name) . ' ('
+      . $self->quote($constraint->table->qualified_name) . ' ('
       . join(', ', map $self->quote($_), $constraint->fields) . ')'
       . ' WHERE '
       . join(' AND ', map $self->quote($_->name) . ' IS NOT NULL', grep { $_->is_nullable } $constraint->fields) . ';';
@@ -103,9 +103,9 @@ sub foreign_key_constraint {
   }
 
   'ALTER TABLE '
-      . $self->quote($constraint->table->name)
+      . $self->quote($constraint->table->qualified_name)
       . ' ADD CONSTRAINT '
-      . $self->quote($constraint->name || $constraint->table->name . '_fk')
+      . $self->quote($constraint->name || $constraint->table->qualified_name . '_fk')
       . ' FOREIGN KEY' . ' ('
       . join(', ', map $self->quote($_), $constraint->fields)
       . ') REFERENCES '
@@ -163,7 +163,7 @@ sub table {
   join("\n", $self->table_comments($table), '')
       . join("\n\n",
           'CREATE TABLE '
-        . $self->quote($table->name) . " (\n"
+        . $self->quote($table->qualified_name) . " (\n"
         . join(",\n", map {"  $_"} $self->fields($table), $self->constraints($table),) . "\n);",
         $self->unique_constraints_multiple($table), $self->indices($table),);
 }
@@ -182,14 +182,14 @@ sub unique_constraints_multiple {
 
 sub drop_table {
   my ($self, $table) = @_;
-  my $name   = $table->name;
+  my $name   = $table->qualified_name;
   my $q_name = $self->quote($name);
   "IF EXISTS (SELECT name FROM sysobjects WHERE name = '$name' AND type = 'U')" . " DROP TABLE $q_name;";
 }
 
 sub remove_table_constraints {
   my ($self, $table) = @_;
-  my $name   = $table->name;
+  my $name   = $table->qualified_name;
   my $q_name = $self->quote($name);
   "IF EXISTS (SELECT name FROM sysobjects WHERE name = '$name' AND type = 'U')"
       . " ALTER TABLE $q_name NOCHECK CONSTRAINT all;";
@@ -228,7 +228,7 @@ sub schema {
 
   $self->header_comments
       . $self->drop_tables($schema)
-      . join("\n\n", map $self->table($_), grep { $_->name } $schema->get_tables) . "\n"
+      . join("\n\n", map $self->table($_), grep { $_->qualified_name } $schema->get_tables) . "\n"
       . join "\n", $self->foreign_key_constraints($schema);
 }
 

lib/SQL/Translator/Parser/Oracle.pm

@@ -206,19 +206,25 @@ index_expr: parens_name_list
       $return = "$item[2]($arg_list)";
    }
 
-create : /create/i /or replace/i /trigger/i table_name not_end m#^/$#im
+dml_event: /DELETE|INSERT|UPDATE/i {
+    $item[1]
+}
+
+create : /create/i /or replace/i /trigger/i table_name /BEFORE|AFTER|INSTEAD OF/i dml_event(s) /ON/i table_name not_end m#^/$#im
         {
           @table_comments = ();
         my $trigger_name = $item[4];
         # Hack to strip owner from trigger name
         $trigger_name =~ s#.*\.##;
         my $owner = '';
-        my $action = "$item[1] $item[2] $item[3] $item[4] $item[5]";
-
-        $triggers{ $trigger_name }{'order'}  = ++$trigger_order;
-        $triggers{ $trigger_name }{'name'}   = $trigger_name;
-        $triggers{ $trigger_name }{'owner'}  = $owner;
-        $triggers{ $trigger_name }{'action'}    = $action;
+        my $action = "$item[1] $item[2] $item[3] $item[4] $item[5] "
+            .(join ' ', @{$item[6]}) ." $item[7] $item[8]\n$item[9]";
+
+        $triggers{ $trigger_name }{'order'}    = ++$trigger_order;
+        $triggers{ $trigger_name }{'name'}     = $trigger_name;
+        $triggers{ $trigger_name }{'on_table'} = $item[8];
+        $triggers{ $trigger_name }{'owner'}    = $owner;
+        $triggers{ $trigger_name }{'action'}   = $action;
         }
 
 create : /create/i /or replace/i /procedure/i table_name not_end m#^/$#im
@@ -732,12 +738,13 @@ sub parse {
     );
   }
 
-  my @triggers = sort { $result->{triggers}->{$a}->{'order'} <=> $result->{triggers}->{$b}->{'order'} }
-      keys %{ $result->{triggers} };
+  my $trg = $result->{triggers};
+  my @triggers = sort { $trg->{$a}->{'order'} <=> $trg->{$b}->{'order'} } keys %$trg;
   foreach my $trigger_name (@triggers) {
     $schema->add_trigger(
-      name   => $trigger_name,
-      action => $result->{triggers}->{$trigger_name}->{action},
+      name     => $trigger_name,
+      action   => $trg->{$trigger_name}->{action},
+      on_table => $trg->{$trigger_name}->{on_table},
     );
   }