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