lib/SQL/Translator/Parser/Access.pm

   1 package SQL::Translator::Parser::Access;
   2
   3 =head1 NAME
   4
   5 SQL::Translator::Parser::Access - parser for Access as produced by mdbtools
   6
   7 =head1 SYNOPSIS
   8
   9   use SQL::Translator;
  10   use SQL::Translator::Parser::Access;
  11
  12   my $translator = SQL::Translator->new;
  13   $translator->parser("SQL::Translator::Parser::Access");
  14
  15 =head1 DESCRIPTION
  16
  17 The grammar derived from the MySQL grammar.  The input is expected to be
  18 something similar to the output of mdbtools (http://mdbtools.sourceforge.net/).
  19
  20 =cut
  21
  22 use strict;
  23 use vars qw[ $DEBUG $VERSION $GRAMMAR @EXPORT_OK ];
  24 $VERSION = '1.59';
  25 $DEBUG   = 0 unless defined $DEBUG;
  26
  27 use Data::Dumper;
  28 use Parse::RecDescent;
  29 use Exporter;
  30 use base qw(Exporter);
  31
  32 @EXPORT_OK = qw(parse);
  33
  34 # Enable warnings within the Parse::RecDescent module.
  35 $::RD_ERRORS = 1; # Make sure the parser dies when it encounters an error
  36 $::RD_WARN   = 1; # Enable warnings. This will warn on unused rules &c.
  37 $::RD_HINT   = 1; # Give out hints to help fix problems.
  38
  39 $GRAMMAR = q!
  40
  41 {
  42     my ( %tables, $table_order, @table_comments );
  43 }
  44
  45 #
  46 # The "eofile" rule makes the parser fail if any "statement" rule
  47 # fails.  Otherwise, the first successful match by a "statement"
  48 # won't cause the failure needed to know that the parse, as a whole,
  49 # failed. -ky
  50 #
  51 startrule : statement(s) eofile { \%tables }
  52
  53 eofile : /^\Z/
  54
  55 statement : comment
  56     | use
  57     | set
  58     | drop
  59     | create
  60     | <error>
  61
  62 use : /use/i WORD ';'
  63     { @table_comments = () }
  64
  65 set : /set/i /[^;]+/ ';'
  66     { @table_comments = () }
  67
  68 drop : /drop/i TABLE /[^;]+/ ';'
  69
  70 drop : /drop/i WORD(s) ';'
  71     { @table_comments = () }
  72
  73 create : CREATE /database/i WORD ';'
  74     { @table_comments = () }
  75
  76 create : CREATE TABLE table_name '(' create_definition(s /,/) ')' ';'
  77     {
  78         my $table_name                       = $item{'table_name'};
  79         $tables{ $table_name }{'order'}      = ++$table_order;
  80         $tables{ $table_name }{'table_name'} = $table_name;
  81
  82         if ( @table_comments ) {
  83             $tables{ $table_name }{'comments'} = [ @table_comments ];
  84             @table_comments = ();
  85         }
  86
  87         my $i = 1;
  88         for my $definition ( @{ $item[5] } ) {
  89             if ( $definition->{'supertype'} eq 'field' ) {
  90                 my $field_name = $definition->{'name'};
  91                 $tables{ $table_name }{'fields'}{ $field_name } =
  92                     { %$definition, order => $i };
  93                 $i++;
  94
  95                 if ( $definition->{'is_primary_key'} ) {
  96                     push @{ $tables{ $table_name }{'constraints'} },
  97                         {
  98                             type   => 'primary_key',
  99                             fields => [ $field_name ],
 100                         }
 101                     ;
 102                 }
 103             }
 104             elsif ( $definition->{'supertype'} eq 'constraint' ) {
 105                 push @{ $tables{ $table_name }{'constraints'} }, $definition;
 106             }
 107             elsif ( $definition->{'supertype'} eq 'index' ) {
 108                 push @{ $tables{ $table_name }{'indices'} }, $definition;
 109             }
 110         }
 111
 112         1;
 113     }
 114
 115 create : CREATE UNIQUE(?) /(index|key)/i index_name /on/i table_name '(' field_name(s /,/) ')' ';'
 116     {
 117         @table_comments = ();
 118         push @{ $tables{ $item{'table_name'} }{'indices'} },
 119             {
 120                 name   => $item[4],
 121                 type   => $item[2] ? 'unique' : 'normal',
 122                 fields => $item[8],
 123             }
 124         ;
 125     }
 126
 127 create_definition : constraint
 128     | index
 129     | field
 130     | comment
 131     | <error>
 132
 133 comment : /^\s*--(.*)\n/
 134     {
 135         my $comment =  $1;
 136         $return     = $comment;
 137         push @table_comments, $comment;
 138     }
 139
 140 field : field_name data_type field_qualifier(s?) reference_definition(?)
 141     {
 142         $return = {
 143             supertype   => 'field',
 144             name        => $item{'field_name'},
 145             data_type   => $item{'data_type'}{'type'},
 146             size        => $item{'data_type'}{'size'},
 147             constraints => $item{'reference_definition(?)'},
 148         }
 149     }
 150     | <error>
 151
 152 field_qualifier : not_null
 153     {
 154         $return = {
 155              null => $item{'not_null'},
 156         }
 157     }
 158
 159 field_qualifier : default_val
 160     {
 161         $return = {
 162              default => $item{'default_val'},
 163         }
 164     }
 165
 166 field_qualifier : auto_inc
 167     {
 168         $return = {
 169              is_auto_inc => $item{'auto_inc'},
 170         }
 171     }
 172
 173 field_qualifier : primary_key
 174     {
 175         $return = {
 176              is_primary_key => $item{'primary_key'},
 177         }
 178     }
 179
 180 field_qualifier : unsigned
 181     {
 182         $return = {
 183              is_unsigned => $item{'unsigned'},
 184         }
 185     }
 186
 187 field_qualifier : /character set/i WORD
 188     {
 189         $return = {
 190             character_set => $item[2],
 191         }
 192     }
 193
 194 reference_definition : /references/i table_name parens_field_list(?) match_type(?) on_delete(?) on_update(?)
 195     {
 196         $return = {
 197             type             => 'foreign_key',
 198             reference_table  => $item[2],
 199             reference_fields => $item[3][0],
 200             match_type       => $item[4][0],
 201             on_delete        => $item[5][0],
 202             on_update        => $item[6][0],
 203         }
 204     }
 205
 206 match_type : /match full/i { 'full' }
 207     |
 208     /match partial/i { 'partial' }
 209
 210 on_delete : /on delete/i reference_option
 211     { $item[2] }
 212
 213 on_update : /on update/i reference_option
 214     { $item[2] }
 215
 216 reference_option: /restrict/i |
 217     /cascade/i   |
 218     /set null/i  |
 219     /no action/i |
 220     /set default/i
 221     { $item[1] }
 222
 223 index : normal_index
 224     | fulltext_index
 225     | <error>
 226
 227 table_name   : NAME
 228
 229 field_name   : NAME
 230
 231 index_name   : NAME
 232
 233 data_type    : access_data_type parens_value_list(s?) type_qualifier(s?)
 234     {
 235         $return        = {
 236             type       => $item[1],
 237             size       => $item[2][0],
 238             qualifiers => $item[3],
 239         }
 240     }
 241
 242 access_data_type : /long integer/i { $return = 'Long Integer' }
 243     | /text/i { $return = 'Text' }
 244     | /datetime (\(short\))?/i { $return = 'DateTime' }
 245     | /boolean/i { $return = 'Boolean' }
 246     | WORD
 247
 248 parens_field_list : '(' field_name(s /,/) ')'
 249     { $item[2] }
 250
 251 parens_value_list : '(' VALUE(s /,/) ')'
 252     { $item[2] }
 253
 254 type_qualifier : /(BINARY|UNSIGNED|ZEROFILL)/i
 255     { lc $item[1] }
 256
 257 field_type   : WORD
 258
 259 create_index : /create/i /index/i
 260
 261 not_null     : /not/i /null/i { $return = 0 }
 262
 263 unsigned     : /unsigned/i { $return = 0 }
 264
 265 default_val : /default/i /'(?:.*?\\')*.*?'|(?:')?[\w\d:.-]*(?:')?/
 266     {
 267         $item[2] =~ s/^\s*'|'\s*$//g;
 268         $return  =  $item[2];
 269     }
 270
 271 auto_inc : /auto_increment/i { 1 }
 272
 273 primary_key : /primary/i /key/i { 1 }
 274
 275 constraint : primary_key_def
 276     | unique_key_def
 277     | foreign_key_def
 278     | <error>
 279
 280 foreign_key_def : foreign_key_def_begin parens_field_list reference_definition
 281     {
 282         $return              =  {
 283             supertype        => 'constraint',
 284             type             => 'foreign_key',
 285             name             => $item[1],
 286             fields           => $item[2],
 287             %{ $item{'reference_definition'} },
 288         }
 289     }
 290
 291 foreign_key_def_begin : /constraint/i /foreign key/i
 292     { $return = '' }
 293     |
 294     /constraint/i WORD /foreign key/i
 295     { $return = $item[2] }
 296     |
 297     /foreign key/i
 298     { $return = '' }
 299
 300 primary_key_def : primary_key index_name(?) '(' name_with_opt_paren(s /,/) ')'
 301     {
 302         $return       = {
 303             supertype => 'constraint',
 304             name      => $item{'index_name(?)'}[0],
 305             type      => 'primary_key',
 306             fields    => $item[4],
 307         };
 308     }
 309
 310 unique_key_def : UNIQUE KEY(?) index_name(?) '(' name_with_opt_paren(s /,/) ')'
 311     {
 312         $return       = {
 313             supertype => 'constraint',
 314             name      => $item{'index_name(?)'}[0],
 315             type      => 'unique',
 316             fields    => $item[5],
 317         }
 318     }
 319
 320 normal_index : KEY index_name(?) '(' name_with_opt_paren(s /,/) ')'
 321     {
 322         $return       = {
 323             supertype => 'index',
 324             type      => 'normal',
 325             name      => $item{'index_name(?)'}[0],
 326             fields    => $item[4],
 327         }
 328     }
 329
 330 fulltext_index : /fulltext/i KEY(?) index_name(?) '(' name_with_opt_paren(s /,/) ')'
 331     {
 332         $return       = {
 333             supertype => 'index',
 334             type      => 'fulltext',
 335             name      => $item{'index_name(?)'}[0],
 336             fields    => $item[5],
 337         }
 338     }
 339
 340 name_with_opt_paren : NAME parens_value_list(s?)
 341     { $item[2][0] ? "$item[1]($item[2][0][0])" : $item[1] }
 342
 343 UNIQUE : /unique/i { 1 }
 344
 345 KEY : /key/i | /index/i
 346
 347 table_option : WORD /\s*=\s*/ WORD
 348     {
 349         $return = { $item[1] => $item[3] };
 350     }
 351
 352 CREATE : /create/i
 353
 354 TEMPORARY : /temporary/i
 355
 356 TABLE : /table/i
 357
 358 WORD : /\w+/
 359
 360 DIGITS : /\d+/
 361
 362 COMMA : ','
 363
 364 NAME    : "`" /\w+/ "`"
 365     { $item[2] }
 366     | /\w+/
 367     { $item[1] }
 368
 369 VALUE   : /[-+]?\.?\d+(?:[eE]\d+)?/
 370     { $item[1] }
 371     | /'.*?'/
 372     {
 373         # remove leading/trailing quotes
 374         my $val = $item[1];
 375         $val    =~ s/^['"]|['"]$//g;
 376         $return = $val;
 377     }
 378     | /NULL/
 379     { 'NULL' }
 380
 381 !;
 382
 383 # -------------------------------------------------------------------
 384 sub parse {
 385     my ( $translator, $data ) = @_;
 386     my $parser = Parse::RecDescent->new($GRAMMAR);
 387
 388     local $::RD_TRACE  = $translator->trace ? 1 : undef;
 389     local $DEBUG       = $translator->debug;
 390
 391     unless (defined $parser) {
 392         return $translator->error("Error instantiating Parse::RecDescent ".
 393             "instance: Bad grammer");
 394     }
 395
 396     my $result = $parser->startrule($data);
 397     return $translator->error( "Parse failed." ) unless defined $result;
 398     warn Dumper( $result ) if $DEBUG;
 399
 400     my $schema = $translator->schema;
 401     my @tables = sort {
 402         $result->{ $a }->{'order'} <=> $result->{ $b }->{'order'}
 403     } keys %{ $result };
 404
 405     for my $table_name ( @tables ) {
 406         my $tdata =  $result->{ $table_name };
 407         my $table =  $schema->add_table(
 408             name  => $tdata->{'table_name'},
 409         ) or die $schema->error;
 410
 411         $table->comments( $tdata->{'comments'} );
 412
 413         my @fields = sort {
 414             $tdata->{'fields'}->{$a}->{'order'}
 415             <=>
 416             $tdata->{'fields'}->{$b}->{'order'}
 417         } keys %{ $tdata->{'fields'} };
 418
 419         for my $fname ( @fields ) {
 420             my $fdata = $tdata->{'fields'}{ $fname };
 421             my $field = $table->add_field(
 422                 name              => $fdata->{'name'},
 423                 data_type         => $fdata->{'data_type'},
 424                 size              => $fdata->{'size'},
 425                 default_value     => $fdata->{'default'},
 426                 is_auto_increment => $fdata->{'is_auto_inc'},
 427                 is_nullable       => $fdata->{'null'},
 428                 comments          => $fdata->{'comments'},
 429             ) or die $table->error;
 430
 431             $table->primary_key( $field->name ) if $fdata->{'is_primary_key'};
 432         }
 433
 434         for my $idata ( @{ $tdata->{'indices'} || [] } ) {
 435             my $index  =  $table->add_index(
 436                 name   => $idata->{'name'},
 437                 type   => uc $idata->{'type'},
 438                 fields => $idata->{'fields'},
 439             ) or die $table->error;
 440         }
 441     }
 442
 443     return 1;
 444 }
 445
 446 1;
 447
 448 # -------------------------------------------------------------------
 449 # Where man is not nature is barren.
 450 # William Blake
 451 # -------------------------------------------------------------------
 452
 453 =pod
 454
 455 =head1 AUTHOR
 456
 457 Ken Y. Clark E<lt>kclark@cpan.orgE<gt>.
 458
 459 =head1 SEE ALSO
 460
 461 perl(1), Parse::RecDescent, SQL::Translator::Schema.
 462
 463 =cut