lib/SQL/Translator/Parser/Access.pm

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