From: Chris Hilton Date: Mon, 27 Jun 2005 19:01:31 +0000 (+0000) Subject: A Parser for SQL Server, mostly copied from Sybase parser and geared toward working... X-Git-Tag: v0.11008~531 X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=be4469ab20a62cd26d2a08d47ae2f40ad0d840b8;p=dbsrgits%2FSQL-Translator.git A Parser for SQL Server, mostly copied from Sybase parser and geared toward working with SQLServer Producer output --- diff --git a/lib/SQL/Translator/Parser/SQLServer.pm b/lib/SQL/Translator/Parser/SQLServer.pm new file mode 100644 index 0000000..e97f4c2 --- /dev/null +++ b/lib/SQL/Translator/Parser/SQLServer.pm @@ -0,0 +1,485 @@ +package SQL::Translator::Parser::SQLServer; + +# ------------------------------------------------------------------- +# $Id: SQLServer.pm,v 1.1 2005-06-27 19:01:31 duality72 Exp $ +# ------------------------------------------------------------------- +# Copyright (C) 2002-4 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 + +=head1 SYNOPSIS + + use SQL::Translator::Parser::SQLServer; + +=head1 DESCRIPTION + +Adapted from Parser::Sybase and mostly parses the output of +Producer::SQLServer. The parsing is by no means complete and +should probably be considered a work in progress. + +=cut + +use strict; + +use vars qw[ $DEBUG $VERSION $GRAMMAR @EXPORT_OK ]; +$VERSION = sprintf "%d.%02d", q$Revision: 1.1 $ =~ /(\d+)\.(\d+)/; +$DEBUG = 0 unless defined $DEBUG; + +use Data::Dumper; +use Parse::RecDescent; +use Exporter; +use base qw(Exporter); + +@EXPORT_OK = qw(parse); + +$::RD_ERRORS = 1; +$::RD_WARN = 1; +$::RD_HINT = 1; + +$GRAMMAR = q{ + +{ + my ( %tables, @table_comments, $table_order ); +} + +startrule : statement(s) eofile { \%tables } + +eofile : /^\Z/ + +statement : create_table + | create_procedure + | create_index + | create_constraint + | comment + | use + | setuser + | if + | print + | grant + | exec + | + +use : /use/i WORD GO + { @table_comments = () } + +setuser : /setuser/i NAME GO + +if : /if/i object_not_null begin if_command end GO + +if_command : grant + | create_index + | create_constraint + +object_not_null : /object_id/i '(' ident ')' /is not null/i + +print : /\s*/ /print/i /.*/ + +else : /else/i /.*/ + +begin : /begin/i + +end : /end/i + +grant : /grant/i /[^\n]*/ + +exec : exec_statement(s) GO + +exec_statement : /exec/i /[^\n]+/ + +comment : /^\s*(?:#|-{2}).*\n/ + { + my $comment = $item[1]; + $comment =~ s/^\s*(#|--)\s*//; + $comment =~ s/\s*$//; + $return = $comment; + push @table_comments, $comment; + } + +comment : comment_start comment_middle comment_end + { + my $comment = $item[2]; + $comment =~ s/^\s*|\s*$//mg; + $comment =~ s/^\**\s*//mg; + push @table_comments, $comment; + } + +comment_start : m#^\s*\/\*# + +comment_end : m#\s*\*\/# + +comment_middle : m{([^*]+|\*(?!/))*} + +# +# Create table. +# +create_table : /create/i /table/i ident '(' create_def(s /,/) ')' lock(?) on_system(?) ';' GO(?) + { + my $table_owner = $item[3]{'owner'}; + my $table_name = $item[3]{'name'}; + + if ( @table_comments ) { + $tables{ $table_name }{'comments'} = [ @table_comments ]; + @table_comments = (); + } + + $tables{ $table_name }{'order'} = ++$table_order; + $tables{ $table_name }{'name'} = $table_name; + $tables{ $table_name }{'owner'} = $table_owner; + $tables{ $table_name }{'system'} = $item[7]; + + my $i = 0; + for my $def ( @{ $item[5] } ) { + if ( $def->{'supertype'} eq 'field' ) { + my $field_name = $def->{'name'}; + $tables{ $table_name }{'fields'}{ $field_name } = + { %$def, order => $i }; + $i++; + + if ( $def->{'is_primary_key'} ) { + push @{ $tables{ $table_name }{'constraints'} }, { + type => 'primary_key', + fields => [ $field_name ], + }; + } + } + elsif ( $def->{'supertype'} eq 'constraint' ) { + push @{ $tables{ $table_name }{'constraints'} }, $def; + } + else { + push @{ $tables{ $table_name }{'indices'} }, $def; + } + } + } + +create_constraint : /create/i constraint + { + @table_comments = (); + push @{ $tables{ $item[2]{'table'} }{'constraints'} }, $item[2]; + } + +create_index : /create/i index + { + @table_comments = (); + push @{ $tables{ $item[2]{'table'} }{'indices'} }, $item[2]; + } + +create_procedure : /create/i /procedure/i procedure_body GO + { + @table_comments = (); + } + +procedure_body : not_go(s) + +not_go : /((?!go).)*/ + +create_def : constraint + | index + | field + +blank : /\s*/ + +field : field_name data_type field_qualifier(s?) + { + my %qualifiers = map { %$_ } @{ $item{'field_qualifier(s?)'} || [] }; + my $nullable = defined $qualifiers{'nullable'} + ? $qualifiers{'nullable'} : 1; + $return = { + supertype => 'field', + 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{'auto_inc'}, +# is_primary_key => $item{'primary_key'}[0], + } + } + +field_qualifier : nullable + { + $return = { + nullable => $item{'nullable'}, + } + } + +field_qualifier : default_val + { + $return = { + default_val => $item{'default_val'}, + } + } + +field_qualifier : auto_inc + { + $return = { + is_auto_inc => $item{'auto_inc'}, + } + } + +constraint : primary_key_constraint + | foreign_key_constraint + | unique_constraint + +field_name : WORD + +index_name : WORD + +table_name : WORD + +data_type : WORD field_size(?) + { + $return = { + type => $item[1], + size => $item[2][0] + } + } + +lock : /lock/i /datarows/i + +field_type : WORD + +field_size : '(' num_range ')' { $item{'num_range'} } + +num_range : DIGITS ',' DIGITS + { $return = $item[1].','.$item[3] } + | DIGITS + { $return = $item[1] } + + +nullable : /not/i /null/i + { $return = 0 } + | /null/i + { $return = 1 } + +default_val : /default/i /(?:')?[^']*(?:')?/ + { $item[2]=~ s/'//g; $return = $item[2] } + +auto_inc : /identity/i { 1 } + +primary_key_constraint : /constraint/i index_name(?) /primary/i /key/i parens_field_list + { + $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_do(?) on_update_do(?) + { + $return = { + supertype => 'constraint', + name => $item[2][0], + type => 'foreign_key', + fields => $item[5], + reference_table => $item[7], + reference_fields => $item[8][0], + on_delete_do => $item[9][0], + on_update_do => $item[10][0], + } + } + +unique_constraint : /unique/i clustered(?) INDEX(?) index_name(?) on_table(?) parens_field_list + { + $return = { + supertype => 'constraint', + type => 'unique', + clustered => $item[2][0], + name => $item[4][0], + table => $item[5][0], + fields => $item[6], + } + } + +on_delete_do : /on delete/i reference_option + { $item[2] } + +on_update_do : /on update/i reference_option + { $item[2] } + +reference_option: /cascade/i | + /no action/i + { $item[1] } + +clustered : /clustered/i + { $return = 1 } + | /nonclustered/i + { $return = 0 } + +INDEX : /index/i + +on_table : /on/i table_name + { $return = $item[2] } + +on_system : /on/i /system/i + { $return = 1 } + +index : clustered(?) INDEX index_name(?) on_table(?) parens_field_list ';' + { + $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 + { $return = { name => $item[1] } } + +GO : /^go/i + +NAME : QUOTE(?) /\w+/ QUOTE(?) + { $item[2] } + +WORD : /[\w#]+/ + +DIGITS : /\d+/ + +COMMA : ',' + +QUOTE : /'/ + +}; + +# ------------------------------------------------------------------- +sub parse { + my ( $translator, $data ) = @_; + my $parser = Parse::RecDescent->new($GRAMMAR); + + 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 $result = $parser->startrule($data); + return $translator->error( "Parse failed." ) unless defined $result; + warn Dumper( $result ) if $DEBUG; + + my $schema = $translator->schema; + my @tables = sort { + $result->{ $a }->{'order'} <=> $result->{ $b }->{'order'} + } keys %{ $result }; + + for my $table_name ( @tables ) { + my $tdata = $result->{ $table_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'} + <=> + $tdata->{'fields'}->{$b}->{'order'} + } keys %{ $tdata->{'fields'} }; + + for my $fname ( @fields ) { + my $fdata = $tdata->{'fields'}{ $fname }; + my $field = $table->add_field( + name => $fdata->{'name'}, + data_type => $fdata->{'data_type'}, + size => $fdata->{'size'}, + default_value => $fdata->{'default'}, + is_auto_increment => $fdata->{'is_auto_inc'}, + is_nullable => $fdata->{'nullable'}, + comments => $fdata->{'comments'}, + ) or die $table->error; + + $table->primary_key( $field->name ) if $fdata->{'is_primary_key'}; + + for my $qual ( qw[ binary unsigned zerofill list ] ) { + if ( my $val = $fdata->{ $qual } || $fdata->{ uc $qual } ) { + next if ref $val eq 'ARRAY' && !@$val; + $field->extra( $qual, $val ); + } + } + + if ( $field->data_type =~ /(set|enum)/i && !$field->size ) { + my %extra = $field->extra; + my $longest = 0; + for my $len ( map { length } @{ $extra{'list'} || [] } ) { + $longest = $len if $len > $longest; + } + $field->size( $longest ) if $longest; + } + + for my $cdata ( @{ $fdata->{'constraints'} } ) { + next unless $cdata->{'type'} eq 'foreign_key'; + $cdata->{'fields'} ||= [ $field->name ]; + push @{ $tdata->{'constraints'} }, $cdata; + } + } + + for my $idata ( @{ $tdata->{'indices'} || [] } ) { + my $index = $table->add_index( + name => $idata->{'name'}, + type => uc $idata->{'type'}, + fields => $idata->{'fields'}, + ) or die $table->error; + } + + for my $cdata ( @{ $tdata->{'constraints'} || [] } ) { + my $constraint = $table->add_constraint( + name => $cdata->{'name'}, + type => $cdata->{'type'}, + fields => $cdata->{'fields'}, + reference_table => $cdata->{'reference_table'}, + reference_fields => $cdata->{'reference_fields'}, + match_type => $cdata->{'match_type'} || '', + on_delete => $cdata->{'on_delete_do'}, + on_update => $cdata->{'on_update_do'}, + ) or die $table->error; + } + } + + return 1; +} + +1; + +# ------------------------------------------------------------------- +# Every hero becomes a bore at last. +# Ralph Waldo Emerson +# ------------------------------------------------------------------- + +=pod + +=head1 AUTHOR + +Chris Hilton Echris@dctank.comE - Bulk of code from +Sybase parser, I just tweaked it for SQLServer. Thanks. + +=head1 SEE ALSO + +SQL::Translator, SQL::Translator::Parser::DBI, L. + +=cut