Fix parsing quoted strings with leading spaces

[dbsrgits/SQL-Translator.git] / lib / SQL / Translator / Parser / Oracle.pm

diff --git a/lib/SQL/Translator/Parser/Oracle.pm b/lib/SQL/Translator/Parser/Oracle.pm
index 9bcc35c..12e7fdf 100644 (file)
--- a/lib/SQL/Translator/Parser/Oracle.pm
+++ b/lib/SQL/Translator/Parser/Oracle.pm
@@ -77,25 +77,21 @@ was altered to better handle the syntax created by DDL::Oracle.
 
 use strict;
 use warnings;
-our ( $DEBUG, $GRAMMAR, @EXPORT_OK );
+
 our $VERSION = '1.59';
+
+our $DEBUG;
 $DEBUG   = 0 unless defined $DEBUG;
 
 use Data::Dumper;
-use Parse::RecDescent;
-use Exporter;
-use base qw(Exporter);
-
-@EXPORT_OK = qw(parse);
+use SQL::Translator::Utils qw/ddl_parser_instance/;
 
-# Enable warnings within the Parse::RecDescent module.
-$::RD_ERRORS = 1; # Make sure the parser dies when it encounters an error
-$::RD_WARN   = 1; # Enable warnings. This will warn on unused rules &c.
-$::RD_HINT   = 1; # Give out hints to help fix problems.
+use base qw(Exporter);
+our @EXPORT_OK = qw(parse);
 
-$GRAMMAR = q`
+our $GRAMMAR = <<'END_OF_GRAMMAR';
 
-{ my ( %tables, %indices, %constraints, $table_order, @table_comments, %views, $view_order, %procedures, $proc_order ) }
+{ my ( %tables, %indices, %constraints, $table_order, @table_comments, %views, $view_order, %procedures, $proc_order, %triggers, $trigger_order ) }
 
 #
 # The "eofile" rule makes the parser fail if any "statement" rule
@@ -111,6 +107,7 @@ startrule : statement(s) eofile
             constraints => \%constraints,
             views       => \%views,
             procedures  => \%procedures,
+            triggers    => \%triggers,
         };
     }
 
@@ -127,12 +124,17 @@ statement : remark
     | drop
     | <error>
 
+alter: /alter/i TABLE table_name /add/i table_constraint ';'
+    {
+        my $constraint = $item{table_constraint};
+        $constraint->{type} = $constraint->{constraint_type};
+        push @{$tables{$item{table_name}}{constraints}}, $constraint;
+    }
+
 alter : /alter/i WORD /[^;]+/ ';'
     { @table_comments = () }
 
-drop : /drop/i TABLE ';'
-
-drop : /drop/i WORD(s) ';'
+drop : /drop/i WORD(s) NAME WORD(s?) ';'
     { @table_comments = () }
 
 create : create_table table_name '(' create_definition(s /,/) ')' table_option(s?) ';'
@@ -196,14 +198,29 @@ create : create_index index_name /on/i table_name index_expr table_option(?) ';'
         }
     }
 
-index_expr: parens_word_list
+index_expr: parens_name_list
    { $item[1] }
-   | '(' WORD parens_word_list ')'
+   | '(' WORD parens_name_list ')'
    {
       my $arg_list = join(",", @{$item[3]});
       $return = "$item[2]($arg_list)";
    }
 
+create : /create/i /or replace/i /trigger/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;
+        }
+
 create : /create/i /or replace/i /procedure/i table_name not_end m#^/$#im
    {
       @table_comments = ();
@@ -399,7 +416,7 @@ column_constraint_type : /not\s+null/i { $return = { type => 'not_null' } }
                 expression => $item[2],
             };
         }
-    | /references/i table_name parens_word_list(?) on_delete(?)
+    | /references/i table_name parens_name_list(?) on_delete(?)
     {
         $return              =  {
             type             => 'foreign_key',
@@ -466,13 +483,15 @@ parens_value_list : '(' VALUE(s /,/) ')'
 parens_word_list : '(' WORD(s /,/) ')'
     { $item[2] }
 
+parens_name_list : '(' NAME(s /,/) ')'
+    { $item[2] }
+
 field_meta : default_val
     | column_constraint
 
-default_val  : /default/i /(?:')?[\w\d.-]*(?:')?/
+default_val  : /default/i VALUE
     {
         my $val =  $item[2];
-        $val    =~ s/'//g if defined $val;
         $return =  {
             supertype => 'constraint',
             type      => 'default',
@@ -561,7 +580,7 @@ table_constraint_type : /primary key/i '(' NAME(s /,/) ')'
         }
     }
     |
-    /foreign key/i '(' NAME(s /,/) ')' /references/i table_name parens_word_list(?) on_delete(?)
+    /foreign key/i '(' NAME(s /,/) ')' /references/i table_name parens_name_list(?) on_delete(?)
     {
         $return              =  {
             type             => 'foreign_key',
@@ -582,29 +601,35 @@ UNIQUE : /unique/i { $return = 1 }
 WORD : /\w+/
 
 NAME : /\w+/ { $item[1] }
+    | DQSTRING
 
 TABLE : /table/i
 
-VALUE   : /[-+]?\.?\d+(?:[eE]\d+)?/
-    { $item[1] }
-    | /'.*?'/   # XXX doesn't handle embedded quotes
-    { $item[1] }
-    | /NULL/
+DQSTRING : '"' <skip: ''> /((?:[^"]|"")+)/ '"'
+    { ($return = $item[3]) =~ s/""/"/g; }
+
+SQSTRING : "'" <skip: ''> /((?:[^']|'')*)/ "'"
+    { ($return = $item[3]) =~ s/''/'/g }
+
+VALUE : /[-+]?\d*\.?\d+(?:[eE]\d+)?/
+    | SQSTRING
+    | /null/i
     { 'NULL' }
 
-`;
+END_OF_GRAMMAR
 
 sub parse {
     my ( $translator, $data ) = @_;
-    my $parser = Parse::RecDescent->new($GRAMMAR);
 
-    local $::RD_TRACE = $translator->trace ? 1 : undef;
-    local $DEBUG      = $translator->debug;
+    # Enable warnings within the Parse::RecDescent module.
+    local $::RD_ERRORS = 1 unless defined $::RD_ERRORS; # Make sure the parser dies when it encounters an error
+    local $::RD_WARN   = 1 unless defined $::RD_WARN; # Enable warnings. This will warn on unused rules &c.
+    local $::RD_HINT   = 1 unless defined $::RD_HINT; # Give out hints to help fix problems.
 
-    unless (defined $parser) {
-        return $translator->error("Error instantiating Parse::RecDescent ".
-            "instance: Bad grammer");
-    }
+    local $::RD_TRACE  = $translator->trace ? 1 : undef;
+    local $DEBUG       = $translator->debug;
+
+    my $parser = ddl_parser_instance('Oracle');
 
     my $result = $parser->startrule( $data );
     die "Parse failed.\n" unless defined $result;
@@ -700,6 +725,16 @@ sub parse {
       );
     }
 
+    my @triggers = sort {
+        $result->{triggers}->{ $a }->{'order'} <=> $result->{triggers}->{ $b }->{'order'}
+    } keys %{ $result->{triggers} };
+    foreach my $trigger_name (@triggers) {
+        $schema->add_trigger(
+            name   => $trigger_name,
+            action => $result->{triggers}->{$trigger_name}->{action},
+        );
+    }
+
     return 1;
 }