X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FSQL%2FTranslator%2FParser%2FSQLServer.pm;h=edfe0d033db9396fffa62ac75d71864b2d890611;hb=c601ca5da1eabe59d4dd09b9265923573fb72ec6;hp=21d443e4ab2b5785aa3e26a3ffd8acb9526892a7;hpb=ba506e52c480afe33dfec6b38a12759fad1e7fa2;p=dbsrgits%2FSQL-Translator.git diff --git a/lib/SQL/Translator/Parser/SQLServer.pm b/lib/SQL/Translator/Parser/SQLServer.pm index 21d443e..edfe0d0 100644 --- a/lib/SQL/Translator/Parser/SQLServer.pm +++ b/lib/SQL/Translator/Parser/SQLServer.pm @@ -37,7 +37,7 @@ should probably be considered a work in progress. use strict; use vars qw[ $DEBUG $VERSION $GRAMMAR @EXPORT_OK ]; -$VERSION = '1.60'; +$VERSION = '1.59'; $DEBUG = 0 unless defined $DEBUG; use Data::Dumper; @@ -53,18 +53,28 @@ $::RD_HINT = 1; $GRAMMAR = q{ -{ +{ my ( %tables, @table_comments, $table_order, %procedures, $proc_order, %views, $view_order ); + + 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 ? '...' : () + ); + } + } startrule : statement(s) eofile - { - return { - tables => \%tables, - procedures => \%procedures, - views => \%views, - } - } + { + return { + tables => \%tables, + procedures => \%procedures, + views => \%views, + } + } eofile : /^\Z/ @@ -74,6 +84,7 @@ statement : create_table | create_index | create_constraint | comment + | disable_constraints | drop | use | setuser @@ -81,9 +92,9 @@ statement : create_table | print | grant | exec - | + | /^\Z/ | { _err ($thisline, $text) } -use : /use/i WORD GO +use : /use/i WORD GO { @table_comments = () } setuser : /setuser/i NAME GO @@ -96,6 +107,8 @@ if_command : grant object_not_null : /object_id/i '(' ident ')' /is not null/i +field_not_null : /where/i field_name /is \s+ not \s+ null/ix + print : /\s*/ /print/i /.*/ else : /else/i /.*/ @@ -110,8 +123,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*$//; @@ -120,7 +133,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; @@ -135,7 +148,7 @@ comment_middle : m{([^*]+|\*(?!/))*} drop : if_exists(?) /drop/i tbl_drop END_STATEMENT -tbl_drop : /table/i NAME +tbl_drop : /table/i ident if_exists : /if exists/i '(' /select/i 'name' /from/i 'sysobjects' /[^\)]+/ ')' @@ -143,7 +156,7 @@ 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'}; @@ -161,10 +174,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', @@ -181,17 +194,29 @@ create_table : /create/i /table/i ident '(' create_def(s /,/) ')' lock(?) on_sys } } +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 = (); @@ -204,7 +229,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; @@ -217,7 +242,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; @@ -225,14 +250,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; @@ -247,41 +272,41 @@ 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 @@ -289,17 +314,26 @@ constraint : primary_key_constraint | unique_constraint field_name : WORD + { $return = $item[1] } + | LQUOTE WORD RQUOTE + { $return = $item[2] } index_name : WORD + { $return = $item[1] } + | LQUOTE WORD RQUOTE + { $return = $item[2] } table_name : WORD + { $return = $item[1] } + | LQUOTE WORD RQUOTE + { $return = $item[2] } -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 @@ -321,38 +355,40 @@ nullable : /not/i /null/i default_val : /default/i /null/i { $return = 'null' } - | /default/i /'[^']*'/ + | /default/i /'[^']*'/ { $item[2]=~ s/'//g; $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 = { + $return = { supertype => 'constraint', type => 'unique', name => $item[2][0], @@ -360,16 +396,16 @@ unique_constraint : /constraint/i index_name(?) /unique/i parens_field_list } } -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 @@ -397,27 +433,33 @@ on_system : /on/i /system/i { $return = 1 } index : clustered(?) INDEX index_name(?) on_table(?) parens_field_list END_STATEMENT - { - $return = { + { + $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(?) +ident : QUOTE WORD '.' WORD QUOTE | LQUOTE WORD '.' WORD RQUOTE { $return = { owner => $item[2], name => $item[4] } } + | LQUOTE WORD RQUOTE '.' LQUOTE WORD RQUOTE + { $return = { owner => $item[2], name => $item[6] } } + | LQUOTE WORD RQUOTE + { $return = { name => $item[2] } } + | WORD '.' WORD + { $return = { owner => $item[1], name => $item[3] } } | WORD { $return = { name => $item[1] } } END_STATEMENT : ';' - | GO + | GO GO : /^go/i @@ -432,6 +474,10 @@ COMMA : ',' QUOTE : /'/ +LQUOTE : '[' + +RQUOTE : ']' + }; # ------------------------------------------------------------------- @@ -452,19 +498,19 @@ sub parse { 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'} }; @@ -527,26 +573,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;