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 warnings;
  24 use vars qw[ $DEBUG $VERSION $GRAMMAR @EXPORT_OK ];
  25 $VERSION = '1.59';
  26 $DEBUG   = 0 unless defined $DEBUG;
  27
  28 use Data::Dumper;
  29 use Parse::RecDescent;
  30 use Exporter;
  31 use base qw(Exporter);
  32
  33 @EXPORT_OK = qw(parse);
  34
  35 # Enable warnings within the Parse::RecDescent module.
  36 $::RD_ERRORS = 1; # Make sure the parser dies when it encounters an error
  37 $::RD_WARN   = 1; # Enable warnings. This will warn on unused rules &c.
  38 $::RD_HINT   = 1; # Give out hints to help fix problems.
  39
  40 $GRAMMAR = q!
  41
  42 {
  43     my ( %tables, $table_order, @table_comments );
  44 }
  45
  46 #
  47 # The "eofile" rule makes the parser fail if any "statement" rule
  48 # fails.  Otherwise, the first successful match by a "statement"
  49 # won't cause the failure needed to know that the parse, as a whole,
  50 # failed. -ky
  51 #
  52 startrule : statement(s) eofile { \%tables }
  53
  54 eofile : /^\Z/
  55
  56 statement : comment
  57     | use
  58     | set
  59     | drop
  60     | create
  61     | <error>
  62
  63 use : /use/i WORD ';'
  64     { @table_comments = () }
  65
  66 set : /set/i /[^;]+/ ';'
  67     { @table_comments = () }
  68
  69 drop : /drop/i TABLE /[^;]+/ ';'
  70
  71 drop : /drop/i WORD(s) ';'
  72     { @table_comments = () }
  73
  74 create : CREATE /database/i WORD ';'
  75     { @table_comments = () }
  76
  77 create : CREATE TABLE table_name '(' create_definition(s /,/) ')' ';'
  78     {
  79         my $table_name                       = $item{'table_name'};
  80         $tables{ $table_name }{'order'}      = ++$table_order;
  81         $tables{ $table_name }{'table_name'} = $table_name;
  82
  83         if ( @table_comments ) {
  84             $tables{ $table_name }{'comments'} = [ @table_comments ];
  85             @table_comments = ();
  86         }
  87
  88         my $i = 1;
  89         for my $definition ( @{ $item[5] } ) {
  90             if ( $definition->{'supertype'} eq 'field' ) {
  91                 my $field_name = $definition->{'name'};
  92                 $tables{ $table_name }{'fields'}{ $field_name } =
  93                     { %$definition, order => $i };
  94                 $i++;
  95
  96                 if ( $definition->{'is_primary_key'} ) {
  97                     push @{ $tables{ $table_name }{'constraints'} },
  98                         {
  99                             type   => 'primary_key',
 100                             fields => [ $field_name ],
 101                         }
 102                     ;
 103                 }
 104             }
 105             elsif ( $definition->{'supertype'} eq 'constraint' ) {
 106                 push @{ $tables{ $table_name }{'constraints'} }, $definition;
 107             }
 108             elsif ( $definition->{'supertype'} eq 'index' ) {
 109                 push @{ $tables{ $table_name }{'indices'} }, $definition;
 110             }
 111         }
 112
 113         1;
 114     }
 115
 116 create : CREATE UNIQUE(?) /(index|key)/i index_name /on/i table_name '(' field_name(s /,/) ')' ';'
 117     {
 118         @table_comments = ();
 119         push @{ $tables{ $item{'table_name'} }{'indices'} },
 120             {
 121                 name   => $item[4],
 122                 type   => $item[2] ? 'unique' : 'normal',
 123                 fields => $item[8],
 124             }
 125         ;
 126     }
 127
 128 create_definition : constraint
 129     | index
 130     | field
 131     | comment
 132     | <error>
 133
 134 comment : /^\s*--(.*)\n/
 135     {
 136         my $comment =  $1;
 137         $return     = $comment;
 138         push @table_comments, $comment;
 139     }
 140
 141 field : field_name data_type field_qualifier(s?) reference_definition(?)
 142     {
 143         $return = {
 144             supertype   => 'field',
 145             name        => $item{'field_name'},
 146             data_type   => $item{'data_type'}{'type'},
 147             size        => $item{'data_type'}{'size'},
 148             constraints => $item{'reference_definition(?)'},
 149         }
 150     }
 151     | <error>
 152
 153 field_qualifier : not_null
 154     {
 155         $return = {
 156              null => $item{'not_null'},
 157         }
 158     }
 159
 160 field_qualifier : default_val
 161     {
 162         $return = {
 163              default => $item{'default_val'},
 164         }
 165     }
 166
 167 field_qualifier : auto_inc
 168     {
 169         $return = {
 170              is_auto_inc => $item{'auto_inc'},
 171         }
 172     }
 173
 174 field_qualifier : primary_key
 175     {
 176         $return = {
 177              is_primary_key => $item{'primary_key'},
 178         }
 179     }
 180
 181 field_qualifier : unsigned
 182     {
 183         $return = {
 184              is_unsigned => $item{'unsigned'},
 185         }
 186     }
 187
 188 field_qualifier : /character set/i WORD
 189     {
 190         $return = {
 191             character_set => $item[2],
 192         }
 193     }
 194
 195 reference_definition : /references/i table_name parens_field_list(?) match_type(?) on_delete(?) on_update(?)
 196     {
 197         $return = {
 198             type             => 'foreign_key',
 199             reference_table  => $item[2],
 200             reference_fields => $item[3][0],
 201             match_type       => $item[4][0],
 202             on_delete        => $item[5][0],
 203             on_update        => $item[6][0],
 204         }
 205     }
 206
 207 match_type : /match full/i { 'full' }
 208     |
 209     /match partial/i { 'partial' }
 210
 211 on_delete : /on delete/i reference_option
 212     { $item[2] }
 213
 214 on_update : /on update/i reference_option
 215     { $item[2] }
 216
 217 reference_option: /restrict/i |
 218     /cascade/i   |
 219     /set null/i  |
 220     /no action/i |
 221     /set default/i
 222     { $item[1] }
 223
 224 index : normal_index
 225     | fulltext_index
 226     | <error>
 227
 228 table_name   : NAME
 229
 230 field_name   : NAME
 231
 232 index_name   : NAME
 233
 234 data_type    : access_data_type parens_value_list(s?) type_qualifier(s?)
 235     {
 236         $return        = {
 237             type       => $item[1],
 238             size       => $item[2][0],
 239             qualifiers => $item[3],
 240         }
 241     }
 242
 243 access_data_type : /long integer/i { $return = 'Long Integer' }
 244     | /text/i { $return = 'Text' }
 245     | /datetime (\(short\))?/i { $return = 'DateTime' }
 246     | /boolean/i { $return = 'Boolean' }
 247     | WORD
 248
 249 parens_field_list : '(' field_name(s /,/) ')'
 250     { $item[2] }
 251
 252 parens_value_list : '(' VALUE(s /,/) ')'
 253     { $item[2] }
 254
 255 type_qualifier : /(BINARY|UNSIGNED|ZEROFILL)/i
 256     { lc $item[1] }
 257
 258 field_type   : WORD
 259
 260 create_index : /create/i /index/i
 261
 262 not_null     : /not/i /null/i { $return = 0 }
 263
 264 unsigned     : /unsigned/i { $return = 0 }
 265
 266 default_val : /default/i /'(?:.*?\\')*.*?'|(?:')?[\w\d:.-]*(?:')?/
 267     {
 268         $item[2] =~ s/^\s*'|'\s*$//g;
 269         $return  =  $item[2];
 270     }
 271
 272 auto_inc : /auto_increment/i { 1 }
 273
 274 primary_key : /primary/i /key/i { 1 }
 275
 276 constraint : primary_key_def
 277     | unique_key_def
 278     | foreign_key_def
 279     | <error>
 280
 281 foreign_key_def : foreign_key_def_begin parens_field_list reference_definition
 282     {
 283         $return              =  {
 284             supertype        => 'constraint',
 285             type             => 'foreign_key',
 286             name             => $item[1],
 287             fields           => $item[2],
 288             %{ $item{'reference_definition'} },
 289         }
 290     }
 291
 292 foreign_key_def_begin : /constraint/i /foreign key/i
 293     { $return = '' }
 294     |
 295     /constraint/i WORD /foreign key/i
 296     { $return = $item[2] }
 297     |
 298     /foreign key/i
 299     { $return = '' }
 300
 301 primary_key_def : primary_key index_name(?) '(' name_with_opt_paren(s /,/) ')'
 302     {
 303         $return       = {
 304             supertype => 'constraint',
 305             name      => $item{'index_name(?)'}[0],
 306             type      => 'primary_key',
 307             fields    => $item[4],
 308         };
 309     }
 310
 311 unique_key_def : UNIQUE KEY(?) index_name(?) '(' name_with_opt_paren(s /,/) ')'
 312     {
 313         $return       = {
 314             supertype => 'constraint',
 315             name      => $item{'index_name(?)'}[0],
 316             type      => 'unique',
 317             fields    => $item[5],
 318         }
 319     }
 320
 321 normal_index : KEY index_name(?) '(' name_with_opt_paren(s /,/) ')'
 322     {
 323         $return       = {
 324             supertype => 'index',
 325             type      => 'normal',
 326             name      => $item{'index_name(?)'}[0],
 327             fields    => $item[4],
 328         }
 329     }
 330
 331 fulltext_index : /fulltext/i KEY(?) index_name(?) '(' name_with_opt_paren(s /,/) ')'
 332     {
 333         $return       = {
 334             supertype => 'index',
 335             type      => 'fulltext',
 336             name      => $item{'index_name(?)'}[0],
 337             fields    => $item[5],
 338         }
 339     }
 340
 341 name_with_opt_paren : NAME parens_value_list(s?)
 342     { $item[2][0] ? "$item[1]($item[2][0][0])" : $item[1] }
 343
 344 UNIQUE : /unique/i { 1 }
 345
 346 KEY : /key/i | /index/i
 347
 348 table_option : WORD /\s*=\s*/ WORD
 349     {
 350         $return = { $item[1] => $item[3] };
 351     }
 352
 353 CREATE : /create/i
 354
 355 TEMPORARY : /temporary/i
 356
 357 TABLE : /table/i
 358
 359 WORD : /\w+/
 360
 361 DIGITS : /\d+/
 362
 363 COMMA : ','
 364
 365 NAME    : "`" /\w+/ "`"
 366     { $item[2] }
 367     | /\w+/
 368     { $item[1] }
 369
 370 VALUE   : /[-+]?\.?\d+(?:[eE]\d+)?/
 371     { $item[1] }
 372     | /'.*?'/
 373     {
 374         # remove leading/trailing quotes
 375         my $val = $item[1];
 376         $val    =~ s/^['"]|['"]$//g;
 377         $return = $val;
 378     }
 379     | /NULL/
 380     { 'NULL' }
 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