lib/SQL/Translator/Parser/MySQL.pm

   1 package SQL::Translator::Parser::MySQL;
   2
   3 # -------------------------------------------------------------------
   4 # $Id: MySQL.pm,v 1.8 2002-11-28 04:21:06 kycl4rk Exp $
   5 # -------------------------------------------------------------------
   6 # Copyright (C) 2002 Ken Y. Clark <kclark@cpan.org>,
   7 #                    darren chamberlain <darren@cpan.org>
   8 #
   9 # This program is free software; you can redistribute it and/or
  10 # modify it under the terms of the GNU General Public License as
  11 # published by the Free Software Foundation; version 2.
  12 #
  13 # This program is distributed in the hope that it will be useful, but
  14 # WITHOUT ANY WARRANTY; without even the implied warranty of
  15 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  16 # General Public License for more details.
  17 #
  18 # You should have received a copy of the GNU General Public License
  19 # along with this program; if not, write to the Free Software
  20 # Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA
  21 # 02111-1307  USA
  22 # -------------------------------------------------------------------
  23
  24 =head1 NAME
  25
  26 SQL::Translator::Parser::MySQL - parser for MySQL
  27
  28 =head1 SYNOPSIS
  29
  30   use SQL::Translator;
  31   use SQL::Translator::Parser::MySQL;
  32
  33   my $translator = SQL::Translator->new;
  34   $translator->parser("SQL::Translator::Parser::MySQL");
  35
  36 =head1 DESCRIPTION
  37
  38 The grammar is influenced heavily by Tim Bunce's "mysql2ora" grammar.
  39
  40 =cut
  41
  42 use strict;
  43 use vars qw[ $DEBUG $VERSION $GRAMMAR @EXPORT_OK ];
  44 $VERSION = sprintf "%d.%02d", q$Revision: 1.8 $ =~ /(\d+)\.(\d+)/;
  45 $DEBUG   = 1 unless defined $DEBUG;
  46
  47 use Data::Dumper;
  48 use Parse::RecDescent;
  49 use Exporter;
  50 use base qw(Exporter);
  51
  52 @EXPORT_OK = qw(parse);
  53
  54 # Enable warnings within the Parse::RecDescent module.
  55 $::RD_ERRORS = 1; # Make sure the parser dies when it encounters an error
  56 $::RD_WARN   = 1; # Enable warnings. This will warn on unused rules &c.
  57 $::RD_HINT   = 1; # Give out hints to help fix problems.
  58
  59 my $parser; # should we do this?  There's no programmic way to
  60             # change the grammar, so I think this is safe.
  61
  62 $GRAMMAR = q!
  63
  64 { our ( %tables, $table_order ) }
  65
  66 startrule : statement(s) { \%tables }
  67
  68 statement : comment
  69     | drop
  70     | create
  71     | <error>
  72
  73 drop : /drop/i WORD(s) ';'
  74
  75 create : create_table table_name '(' create_definition(s /,/) ')' table_option(s?) ';'
  76     {
  77         my $table_name                       = $item{'table_name'};
  78         $tables{ $table_name }{'order'}      = ++$table_order;
  79         $tables{ $table_name }{'table_name'} = $table_name;
  80
  81         my $i = 1;
  82         for my $definition ( @{ $item[4] } ) {
  83             if ( $definition->{'type'} eq 'field' ) {
  84                 my $field_name = $definition->{'name'};
  85                 $tables{ $table_name }{'fields'}{ $field_name } =
  86                     { %$definition, order => $i };
  87                 $i++;
  88
  89                 if ( $definition->{'is_primary_key'} ) {
  90                     push @{ $tables{ $table_name }{'indices'} },
  91                         {
  92                             type   => 'primary_key',
  93                             fields => [ $field_name ],
  94                         }
  95                     ;
  96                 }
  97             }
  98             else {
  99                 push @{ $tables{ $table_name }{'indices'} },
 100                     $definition;
 101             }
 102         }
 103
 104         for my $opt ( @{ $item{'table_option'} } ) {
 105             if ( my ( $key, $val ) = each %$opt ) {
 106                 $tables{ $table_name }{'table_options'}{ $key } = $val;
 107             }
 108         }
 109     }
 110
 111 create : /CREATE/i unique(?) /(INDEX|KEY)/i index_name /on/i table_name '(' field_name(s /,/) ')' ';'
 112     {
 113         push @{ $tables{ $item{'table_name'} }{'indices'} },
 114             {
 115                 name   => $item[4],
 116                 type   => $item[2] ? 'unique' : 'normal',
 117                 fields => $item[8],
 118             }
 119         ;
 120     }
 121
 122 create_definition : index
 123     | field
 124     | <error>
 125
 126 comment : /^\s*(?:#|-{2}).*\n/
 127
 128 blank : /\s*/
 129
 130 field : field_name data_type field_qualifier(s?)
 131     {
 132         my %qualifiers = map { %$_ } @{ $item{'field_qualifier'} || [] };
 133         my $null = defined $item{'not_null'} ? $item{'not_null'} : 1;
 134         delete $qualifiers{'not_null'};
 135         if ( my @type_quals = @{ $item{'data_type'}{'qualifiers'} || [] } ) {
 136             $qualifiers{ $_ } = 1 for @type_quals;
 137         }
 138
 139         $return = {
 140             type           => 'field',
 141             name           => $item{'field_name'},
 142             data_type      => $item{'data_type'}{'type'},
 143             size           => $item{'data_type'}{'size'},
 144             list           => $item{'data_type'}{'list'},
 145             null           => $null,
 146             %qualifiers,
 147         }
 148     }
 149     | <error>
 150
 151 field_qualifier : not_null
 152     {
 153         $return = {
 154              null => $item{'not_null'},
 155         }
 156     }
 157
 158 field_qualifier : default_val
 159     {
 160         $return = {
 161              default => $item{'default_val'},
 162         }
 163     }
 164
 165 field_qualifier : auto_inc
 166     {
 167         $return = {
 168              is_auto_inc => $item{'auto_inc'},
 169         }
 170     }
 171
 172 field_qualifier : primary_key
 173     {
 174         $return = {
 175              is_primary_key => $item{'primary_key'},
 176         }
 177     }
 178
 179 field_qualifier : unsigned
 180     {
 181         $return = {
 182              is_unsigned => $item{'unsigned'},
 183         }
 184     }
 185
 186 index : primary_key_index
 187     | unique_index
 188     | normal_index
 189
 190 table_name   : WORD
 191
 192 field_name   : WORD
 193
 194 index_name   : WORD
 195
 196 data_type    : WORD parens_value_list(s?) type_qualifier(s?)
 197     {
 198         my $type = $item[1];
 199         my $size; # field size, applicable only to non-set fields
 200         my $list; # set list, applicable only to sets (duh)
 201
 202         if ( uc($type) =~ /^(SET|ENUM)$/ ) {
 203             $size = undef;
 204             $list = $item[2][0];
 205         }
 206         else {
 207             $size = $item[2][0];
 208             $list = [];
 209         }
 210
 211         $return        = {
 212             type       => $type,
 213             size       => $size,
 214             list       => $list,
 215             qualifiers => $item[3],
 216         }
 217     }
 218
 219 parens_value_list : '(' VALUE(s /,/) ')'
 220     { $item[2] }
 221
 222 type_qualifier : /(BINARY|UNSIGNED|ZEROFILL)/i
 223     { lc $item[1] }
 224
 225 field_type   : WORD
 226
 227 field_size   : '(' num_range ')' { $item{'num_range'} }
 228
 229 num_range    : DIGITS ',' DIGITS
 230     { $return = $item[1].','.$item[3] }
 231     | DIGITS
 232     { $return = $item[1] }
 233
 234 create_table : /create/i /table/i
 235
 236 create_index : /create/i /index/i
 237
 238 not_null     : /not/i /null/i { $return = 0 }
 239
 240 unsigned     : /unsigned/i { $return = 0 }
 241
 242 default_val  : /default/i /(?:')?[\w\d.-]*(?:')?/
 243     {
 244         $item[2] =~ s/'//g;
 245         $return  =  $item[2];
 246     }
 247
 248 auto_inc : /auto_increment/i { 1 }
 249
 250 primary_key : /primary/i /key/i { 1 }
 251
 252 primary_key_index : primary_key index_name(?) '(' field_name(s /,/) ')'
 253     {
 254         $return    = {
 255             name   => $item{'index_name'}[0],
 256             type   => 'primary_key',
 257             fields => $item[4],
 258         }
 259     }
 260
 261 normal_index : key index_name(?) '(' name_with_opt_paren(s /,/) ')'
 262     {
 263         $return    = {
 264             name   => $item{'index_name'}[0],
 265             type   => 'normal',
 266             fields => $item[4],
 267         }
 268     }
 269
 270 unique_index : unique key(?) index_name(?) '(' name_with_opt_paren(s /,/) ')'
 271     {
 272         $return    = {
 273             name   => $item{'index_name'}[0],
 274             type   => 'unique',
 275             fields => $item[5],
 276         }
 277     }
 278
 279 name_with_opt_paren : NAME parens_value_list(s?)
 280     { $item[2][0] ? "$item[1]($item[2][0][0])" : $item[1] }
 281
 282 unique : /unique/i { 1 }
 283
 284 key : /key/i | /index/i
 285
 286 table_option : /[^\s;]*/
 287     {
 288         $return = { split /=/, $item[1] }
 289     }
 290
 291 WORD : /\w+/
 292
 293 DIGITS : /\d+/
 294
 295 COMMA : ','
 296
 297 NAME    : "`" /\w+/ "`"
 298     { $item[2] }
 299     | /\w+/
 300     { $item[1] }
 301
 302 VALUE   : /[-+]?\.?\d+(?:[eE]\d+)?/
 303     { $item[1] }
 304     | /'.*?'/   # XXX doesn't handle embedded quotes
 305     { $item[1] }
 306     | /NULL/
 307     { 'NULL' }
 308
 309 !;
 310
 311 # -------------------------------------------------------------------
 312 sub parse {
 313     my ( $translator, $data ) = @_;
 314     $parser ||= Parse::RecDescent->new($GRAMMAR);
 315
 316     $::RD_TRACE  = $translator->trace ? 1 : undef;
 317     $DEBUG       = $translator->debug;
 318
 319     unless (defined $parser) {
 320         return $translator->error("Error instantiating Parse::RecDescent ".
 321             "instance: Bad grammer");
 322     }
 323
 324     my $result = $parser->startrule($data);
 325     die "Parse failed.\n" unless defined $result;
 326     warn Dumper($result) if $DEBUG;
 327     return $result;
 328 }
 329
 330 1;
 331
 332 #-----------------------------------------------------
 333 # Where man is not nature is barren.
 334 # William Blake
 335 #-----------------------------------------------------
 336
 337 =pod
 338
 339 =head1 AUTHOR
 340
 341 Ken Y. Clark E<lt>kclark@cpan.orgE<gt>,
 342 Chris Mungall
 343
 344 =head1 SEE ALSO
 345
 346 perl(1), Parse::RecDescent.
 347
 348 =cut