X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FSQL%2FTranslator%2FParser%2FSQLServer.pm;h=c4191fdcdfa890971e1a139e7b130f13db90f2bd;hb=c0ec0e22d3f0e3852c00daac5ef5763010b410c3;hp=41dc12011b4928b4706adb606936175ed69668b1;hpb=4ab3763d2ad756c236b757306989cafa08e7f35e;p=dbsrgits%2FSQL-Translator.git diff --git a/lib/SQL/Translator/Parser/SQLServer.pm b/lib/SQL/Translator/Parser/SQLServer.pm index 41dc120..c4191fd 100644 --- a/lib/SQL/Translator/Parser/SQLServer.pm +++ b/lib/SQL/Translator/Parser/SQLServer.pm @@ -1,23 +1,5 @@ package SQL::Translator::Parser::SQLServer; -# ------------------------------------------------------------------- -# 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 @@ -35,36 +17,43 @@ should probably be considered a work in progress. =cut use strict; +use warnings; + +our $VERSION = '1.59'; -use vars qw[ $DEBUG $VERSION $GRAMMAR @EXPORT_OK ]; -$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/ @@ -74,18 +63,20 @@ statement : create_table | create_index | create_constraint | comment + | disable_constraints + | drop | use | setuser | if | print | grant | exec - | + | /^\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 @@ -93,7 +84,9 @@ if_command : grant | 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 /.*/ @@ -109,8 +102,8 @@ exec : exec_statement(s) GO exec_statement : /exec/i /[^\n]+/ -comment : /^\s*(?:#|-{2}).*\n/ - { +comment : /^\s*(?:#|-{2}).*\n/ + { my $comment = $item[1]; $comment =~ s/^\s*(#|--)\s*//; $comment =~ s/\s*$//; @@ -119,7 +112,7 @@ comment : /^\s*(?:#|-{2}).*\n/ } comment : comment_start comment_middle comment_end - { + { my $comment = $item[2]; $comment =~ s/^\s*|\s*$//mg; $comment =~ s/^\**\s*//mg; @@ -132,11 +125,17 @@ comment_end : m#\s*\*\/# 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'}; @@ -154,10 +153,10 @@ create_table : /create/i /table/i ident '(' create_def(s /,/) ')' lock(?) on_sys 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', @@ -174,12 +173,29 @@ create_table : /create/i /table/i ident '(' create_def(s /,/) ')' lock(?) on_sys } } -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 = (); @@ -192,7 +208,7 @@ create_procedure : /create/i PROCEDURE WORD not_go GO 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; @@ -205,7 +221,7 @@ create_procedure : /create/i PROCEDURE '[' WORD '].' WORD not_go GO 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; @@ -213,14 +229,14 @@ create_procedure : /create/i PROCEDURE '[' WORD '].' WORD not_go GO } 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; @@ -235,59 +251,59 @@ create_def : constraint 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 @@ -309,45 +325,57 @@ nullable : /not/i /null/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 : /unique/i clustered(?) INDEX(?) index_name(?) on_table(?) parens_field_list - { - $return = { +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 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 @@ -374,33 +402,37 @@ on_table : /on/i table_name 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#]+/ @@ -408,41 +440,48 @@ DIGITS : /\d+/ COMMA : ',' -QUOTE : /'/ +SQSTRING : "'" /(?:[^']|'')*/ "'" + { ($return = $item[3]) =~ s/''/'/g } -}; +DQSTRING : '"' /(?:[^"]|"")+/ '"' + { ($return = $item[3]) =~ s/""/"/g } + +BQSTRING : '[' /(?:[^]]|]])+/ ']' + { ($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'} }; @@ -505,26 +544,26 @@ sub parse { ) 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;