lib/SQL/Translator/Parser/MySQL.pm

   1 package SQL::Translator::Parser::MySQL;
   2
   3 # -------------------------------------------------------------------
   4 # $Id: MySQL.pm,v 1.7 2002-11-23 01:26:56 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.7 $ =~ /(\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     | create
  70     | <error>
  71
  72 create : create_table table_name '(' create_definition(s /,/) ')' table_option(s?) ';'
  73     {
  74         my $table_name                       = $item{'table_name'};
  75         $tables{ $table_name }{'order'}      = ++$table_order;
  76         $tables{ $table_name }{'table_name'} = $table_name;
  77
  78         my $i = 0;
  79         for my $definition ( @{ $item[4] } ) {
  80             if ( $definition->{'type'} eq 'field' ) {
  81                 my $field_name = $definition->{'name'};
  82                 $tables{ $table_name }{'fields'}{ $field_name } =
  83                     { %$definition, order => $i };
  84                 $i++;
  85
  86                 if ( $definition->{'is_primary_key'} ) {
  87                     push @{ $tables{ $table_name }{'indices'} },
  88                         {
  89                             type   => 'primary_key',
  90                             fields => [ $field_name ],
  91                         }
  92                     ;
  93                 }
  94             }
  95             else {
  96                 push @{ $tables{ $table_name }{'indices'} },
  97                     $definition;
  98             }
  99         }
 100
 101         for my $opt ( @{ $item{'table_option'} } ) {
 102             if ( my ( $key, $val ) = each %$opt ) {
 103                 $tables{ $table_name }{'table_options'}{ $key } = $val;
 104             }
 105         }
 106     }
 107
 108 create : /CREATE/i unique(?) /(INDEX|KEY)/i index_name /on/i table_name '(' field_name(s /,/) ')' ';'
 109     {
 110         push @{ $tables{ $item{'table_name'} }{'indices'} },
 111             {
 112                 name   => $item[4],
 113                 type   => $item[2] ? 'unique' : 'normal',
 114                 fields => $item[8],
 115             }
 116         ;
 117     }
 118
 119 create_definition : index
 120     | field
 121     | <error>
 122
 123 comment : /^\s*(?:#|-{2}).*\n/
 124
 125 blank : /\s*/
 126
 127 field : field_name data_type field_qualifier(s?)
 128     {
 129         my %qualifiers = map { %$_ } @{ $item{'field_qualifier'} || [] };
 130         my $null = defined $item{'not_null'} ? $item{'not_null'} : 1;
 131         delete $qualifiers{'not_null'};
 132         if ( my @type_quals = @{ $item{'data_type'}{'qualifiers'} || [] } ) {
 133             $qualifiers{ $_ } = 1 for @type_quals;
 134         }
 135
 136         $return = {
 137             type           => 'field',
 138             name           => $item{'field_name'},
 139             data_type      => $item{'data_type'}{'type'},
 140             size           => $item{'data_type'}{'size'},
 141             list           => $item{'data_type'}{'list'},
 142             null           => $null,
 143             %qualifiers,
 144         }
 145     }
 146     | <error>
 147
 148 field_qualifier : not_null
 149     {
 150         $return = {
 151              null => $item{'not_null'},
 152         }
 153     }
 154
 155 field_qualifier : default_val
 156     {
 157         $return = {
 158              default => $item{'default_val'},
 159         }
 160     }
 161
 162 field_qualifier : auto_inc
 163     {
 164         $return = {
 165              is_auto_inc => $item{'auto_inc'},
 166         }
 167     }
 168
 169 field_qualifier : primary_key
 170     {
 171         $return = {
 172              is_primary_key => $item{'primary_key'},
 173         }
 174     }
 175
 176 field_qualifier : unsigned
 177     {
 178         $return = {
 179              is_unsigned => $item{'unsigned'},
 180         }
 181     }
 182
 183 index : primary_key_index
 184     | unique_index
 185     | normal_index
 186
 187 table_name   : WORD
 188
 189 field_name   : WORD
 190
 191 index_name   : WORD
 192
 193 data_type    : WORD parens_value_list(s?) type_qualifier(s?)
 194     {
 195         my $type = $item[1];
 196         my $size; # field size, applicable only to non-set fields
 197         my $list; # set list, applicable only to sets (duh)
 198
 199         if ( uc($type) =~ /^(SET|ENUM)$/ ) {
 200             $size = undef;
 201             $list = $item[2][0];
 202         }
 203         else {
 204             $size = $item[2][0];
 205             $list = [];
 206         }
 207
 208         $return        = {
 209             type       => $type,
 210             size       => $size,
 211             list       => $list,
 212             qualifiers => $item[3],
 213         }
 214     }
 215
 216 parens_value_list : '(' VALUE(s /,/) ')'
 217     { $item[2] }
 218
 219 type_qualifier : /(BINARY|UNSIGNED|ZEROFILL)/i
 220     { lc $item[1] }
 221
 222 field_type   : WORD
 223
 224 field_size   : '(' num_range ')' { $item{'num_range'} }
 225
 226 num_range    : DIGITS ',' DIGITS
 227     { $return = $item[1].','.$item[3] }
 228     | DIGITS
 229     { $return = $item[1] }
 230
 231 create_table : /create/i /table/i
 232
 233 create_index : /create/i /index/i
 234
 235 not_null     : /not/i /null/i { $return = 0 }
 236
 237 unsigned     : /unsigned/i { $return = 0 }
 238
 239 default_val  : /default/i /(?:')?[\w\d.-]*(?:')?/
 240     {
 241         $item[2] =~ s/'//g;
 242         $return  =  $item[2];
 243     }
 244
 245 auto_inc : /auto_increment/i { 1 }
 246
 247 primary_key : /primary/i /key/i { 1 }
 248
 249 primary_key_index : primary_key index_name(?) '(' field_name(s /,/) ')'
 250     {
 251         $return    = {
 252             name   => $item{'index_name'}[0],
 253             type   => 'primary_key',
 254             fields => $item[4],
 255         }
 256     }
 257
 258 normal_index : key index_name(?) '(' name_with_opt_paren(s /,/) ')'
 259     {
 260         $return    = {
 261             name   => $item{'index_name'}[0],
 262             type   => 'normal',
 263             fields => $item[4],
 264         }
 265     }
 266
 267 unique_index : unique key(?) index_name(?) '(' name_with_opt_paren(s /,/) ')'
 268     {
 269         $return    = {
 270             name   => $item{'index_name'}[0],
 271             type   => 'unique',
 272             fields => $item[5],
 273         }
 274     }
 275
 276 name_with_opt_paren : NAME parens_value_list(s?)
 277     { $item[2][0] ? "$item[1]($item[2][0][0])" : $item[1] }
 278
 279 unique : /unique/i { 1 }
 280
 281 key : /key/i | /index/i
 282
 283 table_option : /[^\s;]*/
 284     {
 285         $return = { split /=/, $item[1] }
 286     }
 287
 288 WORD : /\w+/
 289
 290 DIGITS : /\d+/
 291
 292 COMMA : ','
 293
 294 NAME    : "`" /\w+/ "`"
 295     { $item[2] }
 296     | /\w+/
 297     { $item[1] }
 298
 299 VALUE   : /[-+]?\.?\d+(?:[eE]\d+)?/
 300     { $item[1] }
 301     | /'.*?'/   # XXX doesn't handle embedded quotes
 302     { $item[1] }
 303     | /NULL/
 304     { 'NULL' }
 305
 306 !;
 307
 308 # -------------------------------------------------------------------
 309 sub parse {
 310     my ( $translator, $data ) = @_;
 311     $parser ||= Parse::RecDescent->new($GRAMMAR);
 312
 313     $::RD_TRACE  = $translator->trace ? 1 : undef;
 314     $DEBUG       = $translator->debug;
 315
 316     unless (defined $parser) {
 317         return $translator->error("Error instantiating Parse::RecDescent ".
 318             "instance: Bad grammer");
 319     }
 320
 321     my $result = $parser->startrule($data);
 322     die "Parse failed.\n" unless defined $result;
 323     warn Dumper($result) if $DEBUG;
 324     return $result;
 325 }
 326
 327 1;
 328
 329 #-----------------------------------------------------
 330 # Where man is not nature is barren.
 331 # William Blake
 332 #-----------------------------------------------------
 333
 334 =pod
 335
 336 =head1 AUTHOR
 337
 338 Ken Y. Clark E<lt>kclark@cpan.orgE<gt>,
 339 Chris Mungall
 340
 341 =head1 SEE ALSO
 342
 343 perl(1), Parse::RecDescent.
 344
 345 =cut