package SQL::Translator::Parser::SQLServer;
-# -------------------------------------------------------------------
-# $Id$
-# -------------------------------------------------------------------
-# Copyright (C) 2002-2009 SQLFairy Authors
-#
-# This program is free software; you can redistribute it and/or
-# modify it under the terms of the GNU General Public License as
-# published by the Free Software Foundation; version 2.
-#
-# This program is distributed in the hope that it will be useful, but
-# WITHOUT ANY WARRANTY; without even the implied warranty of
-# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-# General Public License for more details.
-#
-# You should have received a copy of the GNU General Public License
-# along with this program; if not, write to the Free Software
-# Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA
-# 02111-1307 USA
-# -------------------------------------------------------------------
-
=head1 NAME
SQL::Translator::Parser::SQLServer - parser for SQL Server
=cut
use strict;
+use warnings;
-use vars qw[ $DEBUG $GRAMMAR @EXPORT_OK ];
+our $VERSION = '1.59';
+
+our $DEBUG;
$DEBUG = 0 unless defined $DEBUG;
use Data::Dumper;
-use Parse::RecDescent;
-use Exporter;
+use SQL::Translator::Utils qw/ddl_parser_instance/;
+
use base qw(Exporter);
+our @EXPORT_OK = qw(parse);
-@EXPORT_OK = qw(parse);
+our $GRAMMAR = <<'END_OF_GRAMMAR';
-$::RD_ERRORS = 1;
-$::RD_WARN = 1;
-$::RD_HINT = 1;
+{
+ my ( %tables, @table_comments, $table_order, %procedures, $proc_order, %views, $view_order );
-$GRAMMAR = q{
+ sub _err {
+ my $max_lines = 5;
+ my @up_to_N_lines = split (/\n/, $_[1], $max_lines + 1);
+ die sprintf ("Unable to parse line %d:\n%s\n",
+ $_[0],
+ join "\n", (map { "'$_'" } @up_to_N_lines[0..$max_lines - 1 ]), @up_to_N_lines > $max_lines ? '...' : ()
+ );
+ }
-{
- my ( %tables, @table_comments, $table_order, %procedures, $proc_order, %views, $view_order );
}
startrule : statement(s) eofile
- {
- return {
- tables => \%tables,
- procedures => \%procedures,
- views => \%views,
- }
- }
+ {
+ return {
+ tables => \%tables,
+ procedures => \%procedures,
+ views => \%views,
+ }
+ }
eofile : /^\Z/
| create_index
| create_constraint
| comment
+ | disable_constraints
+ | drop
| use
| setuser
| if
| print
| grant
| exec
- | <error>
+ | /^\Z/ | { _err ($thisline, $text) }
-use : /use/i WORD GO
+use : /use/i NAME GO
{ @table_comments = () }
-setuser : /setuser/i NAME GO
+setuser : /setuser/i USERNAME GO
if : /if/i object_not_null begin if_command end GO
| create_index
| create_constraint
-object_not_null : /object_id/i '(' ident ')' /is not null/i
+object_not_null : /object_id/i '(' SQSTRING ')' /is not null/i
+
+field_not_null : /where/i field_name /is \s+ not \s+ null/ix
print : /\s*/ /print/i /.*/
exec_statement : /exec/i /[^\n]+/
-comment : /^\s*(?:#|-{2}).*\n/
- {
+comment : /^\s*(?:#|-{2}).*\n/
+ {
my $comment = $item[1];
$comment =~ s/^\s*(#|--)\s*//;
$comment =~ s/\s*$//;
}
comment : comment_start comment_middle comment_end
- {
+ {
my $comment = $item[2];
$comment =~ s/^\s*|\s*$//mg;
$comment =~ s/^\**\s*//mg;
comment_middle : m{([^*]+|\*(?!/))*}
+drop : if_exists(?) /drop/i tbl_drop END_STATEMENT
+
+tbl_drop : /table/i ident
+
+if_exists : /if exists/i '(' /select/i 'name' /from/i 'sysobjects' /[^\)]+/ ')'
+
#
# Create table.
#
create_table : /create/i /table/i ident '(' create_def(s /,/) ')' lock(?) on_system(?) END_STATEMENT
- {
+ {
my $table_owner = $item[3]{'owner'};
my $table_name = $item[3]{'name'};
for my $def ( @{ $item[5] } ) {
if ( $def->{'supertype'} eq 'field' ) {
my $field_name = $def->{'name'};
- $tables{ $table_name }{'fields'}{ $field_name } =
+ $tables{ $table_name }{'fields'}{ $field_name } =
{ %$def, order => $i };
$i++;
-
+
if ( $def->{'is_primary_key'} ) {
push @{ $tables{ $table_name }{'constraints'} }, {
type => 'primary_key',
}
}
-create_constraint : /create/i constraint
+disable_constraints : if_exists(?) /alter/i /table/i ident /nocheck/i /constraint/i /all/i END_STATEMENT
+
+# this is for the normal case
+create_constraint : /create/i constraint END_STATEMENT
+ {
+ @table_comments = ();
+ push @{ $tables{ $item[2]{'table'} }{'constraints'} }, $item[2];
+ }
+
+# and this is for the BEGIN/END case
+create_constraint : /create/i constraint
{
@table_comments = ();
push @{ $tables{ $item[2]{'table'} }{'constraints'} }, $item[2];
}
+
+create_constraint : /alter/i /table/i ident /add/i foreign_key_constraint END_STATEMENT
+ {
+ push @{ $tables{ $item[3]{name} }{constraints} }, $item[5];
+ }
+
+
create_index : /create/i index
{
@table_comments = ();
my $proc_name = $item[3];
my $owner = '';
my $sql = "$item[1] $item[2] $proc_name $item[4]";
-
+
$procedures{ $proc_name }{'order'} = ++$proc_order;
$procedures{ $proc_name }{'name'} = $proc_name;
$procedures{ $proc_name }{'owner'} = $owner;
my $proc_name = $item[6];
my $owner = $item[4];
my $sql = "$item[1] $item[2] [$owner].$proc_name $item[7]";
-
+
$procedures{ $proc_name }{'order'} = ++$proc_order;
$procedures{ $proc_name }{'name'} = $proc_name;
$procedures{ $proc_name }{'owner'} = $owner;
}
PROCEDURE : /procedure/i
- | /function/i
+ | /function/i
create_view : /create/i /view/i WORD not_go GO
{
@table_comments = ();
my $view_name = $item[3];
my $sql = "$item[1] $item[2] $item[3] $item[4]";
-
+
$views{ $view_name }{'order'} = ++$view_order;
$views{ $view_name }{'name'} = $view_name;
$views{ $view_name }{'sql'} = $sql;
blank : /\s*/
field : field_name data_type field_qualifier(s?)
- {
+ {
my %qualifiers = map { %$_ } @{ $item{'field_qualifier(s?)'} || [] };
- my $nullable = defined $qualifiers{'nullable'}
+ my $nullable = defined $qualifiers{'nullable'}
? $qualifiers{'nullable'} : 1;
- $return = {
+ $return = {
supertype => 'field',
- name => $item{'field_name'},
+ name => $item{'field_name'},
data_type => $item{'data_type'}{'type'},
size => $item{'data_type'}{'size'},
- nullable => $nullable,
- default => $qualifiers{'default_val'},
- is_auto_inc => $qualifiers{'is_auto_inc'},
-# is_primary_key => $item{'primary_key'}[0],
- }
+ nullable => $nullable,
+ default => $qualifiers{'default_val'},
+ is_auto_inc => $qualifiers{'is_auto_inc'},
+# is_primary_key => $item{'primary_key'}[0],
+ }
}
field_qualifier : nullable
- {
- $return = {
+ {
+ $return = {
nullable => $item{'nullable'},
- }
+ }
}
field_qualifier : default_val
- {
- $return = {
+ {
+ $return = {
default_val => $item{'default_val'},
- }
+ }
}
field_qualifier : auto_inc
- {
- $return = {
+ {
+ $return = {
is_auto_inc => $item{'auto_inc'},
- }
+ }
}
constraint : primary_key_constraint
| foreign_key_constraint
| unique_constraint
-field_name : WORD
+field_name : NAME
-index_name : WORD
+index_name : NAME
-table_name : WORD
+table_name : NAME
-data_type : WORD field_size(?)
- {
- $return = {
- type => $item[1],
+data_type : WORD field_size(?)
+ {
+ $return = {
+ type => $item[1],
size => $item[2][0]
- }
+ }
}
lock : /lock/i /datarows/i
default_val : /default/i /null/i
{ $return = 'null' }
- | /default/i /'[^']*'/
- { $item[2]=~ s/'//g; $return = $item[2] }
+ | /default/i SQSTRING
+ { $return = $item[2] }
+ | /default/i WORD
+ { $return = $item[2] }
auto_inc : /identity/i { 1 }
primary_key_constraint : /constraint/i index_name(?) /primary/i /key/i parens_field_list
- {
- $return = {
+ {
+ $return = {
supertype => 'constraint',
name => $item[2][0],
type => 'primary_key',
fields => $item[5],
- }
+ }
}
foreign_key_constraint : /constraint/i index_name(?) /foreign/i /key/i parens_field_list /references/i table_name parens_field_list(?) on_delete(?) on_update(?)
{
- $return = {
+ $return = {
supertype => 'constraint',
name => $item[2][0],
type => 'foreign_key',
fields => $item[5],
reference_table => $item[7],
- reference_fields => $item[8][0],
+ reference_fields => $item[8][0],
on_delete => $item[9][0],
on_update => $item[10][0],
- }
+ }
+ }
+
+unique_constraint : /constraint/i index_name(?) /unique/i parens_field_list
+ {
+ $return = {
+ supertype => 'constraint',
+ type => 'unique',
+ name => $item[2][0],
+ fields => $item[4],
+ }
}
-unique_constraint : /unique/i clustered(?) INDEX(?) index_name(?) on_table(?) parens_field_list
- {
- $return = {
+unique_constraint : /unique/i clustered(?) INDEX(?) index_name(?) on_table(?) parens_field_list field_not_null(?)
+ {
+ $return = {
supertype => 'constraint',
type => 'unique',
clustered => $item[2][0],
name => $item[4][0],
table => $item[5][0],
fields => $item[6],
- }
+ }
}
on_delete : /on delete/i reference_option
on_system : /on/i /system/i
{ $return = 1 }
-index : clustered(?) INDEX index_name(?) on_table(?) parens_field_list ';'
- {
- $return = {
+index : clustered(?) INDEX index_name(?) on_table(?) parens_field_list END_STATEMENT
+ {
+ $return = {
supertype => 'index',
type => 'normal',
clustered => $item[1][0],
name => $item[3][0],
table => $item[4][0],
fields => $item[5],
- }
+ }
}
parens_field_list : '(' field_name(s /,/) ')'
{ $item[2] }
-ident : QUOTE(?) WORD '.' WORD QUOTE(?)
- { $return = { owner => $item[2], name => $item[4] } }
- | WORD
+ident : NAME '.' NAME
+ { $return = { owner => $item[1], name => $item[3] } }
+ | NAME
{ $return = { name => $item[1] } }
END_STATEMENT : ';'
- | GO
+ | GO
GO : /^go/i
-NAME : QUOTE(?) /\w+/ QUOTE(?)
- { $item[2] }
+USERNAME : WORD
+ | SQSTRING
+
+NAME : WORD
+ | DQSTRING
+ | BQSTRING
WORD : /[\w#]+/
COMMA : ','
-QUOTE : /'/
+SQSTRING : "'" <skip: ''> /(?:[^']|'')*/ "'"
+ { ($return = $item[3]) =~ s/''/'/g }
-};
+DQSTRING : '"' <skip: ''> /(?:[^"]|"")+/ '"'
+ { ($return = $item[3]) =~ s/""/"/g }
+
+BQSTRING : '[' <skip: ''> /(?:[^]]|]])+/ ']'
+ { ($return = $item[3]) =~ s/]]/]/g; }
+
+END_OF_GRAMMAR
-# -------------------------------------------------------------------
sub parse {
my ( $translator, $data ) = @_;
- my $parser = Parse::RecDescent->new($GRAMMAR);
+
+ # 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.
local $::RD_TRACE = $translator->trace ? 1 : undef;
local $DEBUG = $translator->debug;
- unless (defined $parser) {
- return $translator->error("Error instantiating Parse::RecDescent ".
- "instance: Bad grammer");
- }
+ my $parser = ddl_parser_instance('SQLServer');
my $result = $parser->startrule($data);
return $translator->error( "Parse failed." ) unless defined $result;
warn Dumper( $result ) if $DEBUG;
my $schema = $translator->schema;
- my @tables = sort {
+ my @tables = sort {
$result->{tables}->{ $a }->{'order'} <=> $result->{tables}->{ $b }->{'order'}
} keys %{ $result->{tables} };
for my $table_name ( @tables ) {
my $tdata = $result->{tables}->{ $table_name };
- my $table = $schema->add_table( name => $tdata->{'name'} )
+ my $table = $schema->add_table( name => $tdata->{'name'} )
or die "Can't create table '$table_name': ", $schema->error;
$table->comments( $tdata->{'comments'} );
- my @fields = sort {
- $tdata->{'fields'}->{$a}->{'order'}
+ my @fields = sort {
+ $tdata->{'fields'}->{$a}->{'order'}
<=>
$tdata->{'fields'}->{$b}->{'order'}
} keys %{ $tdata->{'fields'} };
) or die $table->error;
}
}
-
- my @procedures = sort {
+
+ my @procedures = sort {
$result->{procedures}->{ $a }->{'order'} <=> $result->{procedures}->{ $b }->{'order'}
} keys %{ $result->{procedures} };
for my $proc_name (@procedures) {
- $schema->add_procedure(
- name => $proc_name,
- owner => $result->{procedures}->{$proc_name}->{owner},
- sql => $result->{procedures}->{$proc_name}->{sql},
- );
+ $schema->add_procedure(
+ name => $proc_name,
+ owner => $result->{procedures}->{$proc_name}->{owner},
+ sql => $result->{procedures}->{$proc_name}->{sql},
+ );
}
- my @views = sort {
+ my @views = sort {
$result->{views}->{ $a }->{'order'} <=> $result->{views}->{ $b }->{'order'}
} keys %{ $result->{views} };
for my $view_name (keys %{ $result->{views} }) {
- $schema->add_view(
- name => $view_name,
- sql => $result->{views}->{$view_name}->{sql},
- );
+ $schema->add_view(
+ name => $view_name,
+ sql => $result->{views}->{$view_name}->{sql},
+ );
}
return 1;
projects / dbsrgits/SQL-Translator.git / blobdiff