=cut
use strict;
-use vars qw[ $DEBUG $VERSION $GRAMMAR @EXPORT_OK ];
-$VERSION = '1.59';
+use warnings;
+
+our $VERSION = '1.62';
+
+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
constraints => \%constraints,
views => \%views,
procedures => \%procedures,
+ triggers => \%triggers,
};
}
| 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?) ';'
}
}
-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 = ();
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',
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',
}
}
|
- /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',
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;
);
}
+ 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;
}