lib/SQL/Translator/Parser/Access.pm

   1 package SQL::Translator::Parser::Access;
   2
   3 # -------------------------------------------------------------------
   4 # $Id: Access.pm,v 1.1 2004-04-19 16:38:17 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.1 $ =~ /(\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 #        my %qualifiers  = map { %$_ } @{ $item{'field_qualifier(s?)'} || [] };
 163 #        if ( my @type_quals = @{ $item{'data_type'}{'qualifiers'} || [] } ) {
 164 #            $qualifiers{ $_ } = 1 for @type_quals;
 165 #        }
 166 #
 167 #        my $null = defined $qualifiers{'not_null'}
 168 #                   ? $qualifiers{'not_null'} : 1;
 169 #        delete $qualifiers{'not_null'};
 170
 171         $return = {
 172             supertype   => 'field',
 173             name        => $item{'field_name'},
 174             data_type   => $item{'data_type'}{'type'},
 175             size        => $item{'data_type'}{'size'},
 176 #            null        => $null,
 177             constraints => $item{'reference_definition(?)'},
 178 #            %qualifiers,
 179         }
 180     }
 181     | <error>
 182
 183 field_qualifier : not_null
 184     {
 185         $return = {
 186              null => $item{'not_null'},
 187         }
 188     }
 189
 190 field_qualifier : default_val
 191     {
 192         $return = {
 193              default => $item{'default_val'},
 194         }
 195     }
 196
 197 field_qualifier : auto_inc
 198     {
 199         $return = {
 200              is_auto_inc => $item{'auto_inc'},
 201         }
 202     }
 203
 204 field_qualifier : primary_key
 205     {
 206         $return = {
 207              is_primary_key => $item{'primary_key'},
 208         }
 209     }
 210
 211 field_qualifier : unsigned
 212     {
 213         $return = {
 214              is_unsigned => $item{'unsigned'},
 215         }
 216     }
 217
 218 field_qualifier : /character set/i WORD
 219     {
 220         $return = {
 221             character_set => $item[2],
 222         }
 223     }
 224
 225 reference_definition : /references/i table_name parens_field_list(?) match_type(?) on_delete_do(?) on_update_do(?)
 226     {
 227         $return = {
 228             type             => 'foreign_key',
 229             reference_table  => $item[2],
 230             reference_fields => $item[3][0],
 231             match_type       => $item[4][0],
 232             on_delete_do     => $item[5][0],
 233             on_update_do     => $item[6][0],
 234         }
 235     }
 236
 237 match_type : /match full/i { 'full' }
 238     |
 239     /match partial/i { 'partial' }
 240
 241 on_delete_do : /on delete/i reference_option
 242     { $item[2] }
 243
 244 on_update_do : /on update/i reference_option
 245     { $item[2] }
 246
 247 reference_option: /restrict/i |
 248     /cascade/i   |
 249     /set null/i  |
 250     /no action/i |
 251     /set default/i
 252     { $item[1] }
 253
 254 index : normal_index
 255     | fulltext_index
 256     | <error>
 257
 258 table_name   : NAME
 259
 260 field_name   : NAME
 261
 262 index_name   : NAME
 263
 264 data_type    : access_data_type parens_value_list(s?) type_qualifier(s?)
 265     {
 266         $return        = {
 267             type       => $item[1],
 268             size       => $item[2][0],
 269             qualifiers => $item[3],
 270         }
 271     }
 272
 273 access_data_type : /long integer/i { $return = 'Long Integer' }
 274     | /text/i { $return = 'Text' }
 275     | /datetime (\(short\))?/i { $return = 'DateTime' }
 276     | /boolean/i { $return = 'Boolean' }
 277     | WORD
 278
 279 parens_field_list : '(' field_name(s /,/) ')'
 280     { $item[2] }
 281
 282 parens_value_list : '(' VALUE(s /,/) ')'
 283     { $item[2] }
 284
 285 type_qualifier : /(BINARY|UNSIGNED|ZEROFILL)/i
 286     { lc $item[1] }
 287
 288 field_type   : WORD
 289
 290 create_index : /create/i /index/i
 291
 292 not_null     : /not/i /null/i { $return = 0 }
 293
 294 unsigned     : /unsigned/i { $return = 0 }
 295
 296 default_val : /default/i /'(?:.*?\\')*.*?'|(?:')?[\w\d:.-]*(?:')?/
 297     {
 298         $item[2] =~ s/^\s*'|'\s*$//g;
 299         $return  =  $item[2];
 300     }
 301
 302 auto_inc : /auto_increment/i { 1 }
 303
 304 primary_key : /primary/i /key/i { 1 }
 305
 306 constraint : primary_key_def
 307     | unique_key_def
 308     | foreign_key_def
 309     | <error>
 310
 311 foreign_key_def : foreign_key_def_begin parens_field_list reference_definition
 312     {
 313         $return              =  {
 314             supertype        => 'constraint',
 315             type             => 'foreign_key',
 316             name             => $item[1],
 317             fields           => $item[2],
 318             %{ $item{'reference_definition'} },
 319         }
 320     }
 321
 322 foreign_key_def_begin : /constraint/i /foreign key/i
 323     { $return = '' }
 324     |
 325     /constraint/i WORD /foreign key/i
 326     { $return = $item[2] }
 327     |
 328     /foreign key/i
 329     { $return = '' }
 330
 331 primary_key_def : primary_key index_name(?) '(' name_with_opt_paren(s /,/) ')'
 332     {
 333         $return       = {
 334             supertype => 'constraint',
 335             name      => $item{'index_name(?)'}[0],
 336             type      => 'primary_key',
 337             fields    => $item[4],
 338         };
 339     }
 340
 341 unique_key_def : UNIQUE KEY(?) index_name(?) '(' name_with_opt_paren(s /,/) ')'
 342     {
 343         $return       = {
 344             supertype => 'constraint',
 345             name      => $item{'index_name(?)'}[0],
 346             type      => 'unique',
 347             fields    => $item[5],
 348         }
 349     }
 350
 351 normal_index : KEY index_name(?) '(' name_with_opt_paren(s /,/) ')'
 352     {
 353         $return       = {
 354             supertype => 'index',
 355             type      => 'normal',
 356             name      => $item{'index_name(?)'}[0],
 357             fields    => $item[4],
 358         }
 359     }
 360
 361 fulltext_index : /fulltext/i KEY(?) index_name(?) '(' name_with_opt_paren(s /,/) ')'
 362     {
 363         $return       = {
 364             supertype => 'index',
 365             type      => 'fulltext',
 366             name      => $item{'index_name(?)'}[0],
 367             fields    => $item[5],
 368         }
 369     }
 370
 371 name_with_opt_paren : NAME parens_value_list(s?)
 372     { $item[2][0] ? "$item[1]($item[2][0][0])" : $item[1] }
 373
 374 UNIQUE : /unique/i { 1 }
 375
 376 KEY : /key/i | /index/i
 377
 378 table_option : WORD /\s*=\s*/ WORD
 379     {
 380         $return = { $item[1] => $item[3] };
 381     }
 382
 383 CREATE : /create/i
 384
 385 TEMPORARY : /temporary/i
 386
 387 TABLE : /table/i
 388
 389 WORD : /\w+/
 390
 391 DIGITS : /\d+/
 392
 393 COMMA : ','
 394
 395 NAME    : "`" /\w+/ "`"
 396     { $item[2] }
 397     | /\w+/
 398     { $item[1] }
 399
 400 VALUE   : /[-+]?\.?\d+(?:[eE]\d+)?/
 401     { $item[1] }
 402     | /'.*?'/
 403     {
 404         # remove leading/trailing quotes
 405         my $val = $item[1];
 406         $val    =~ s/^['"]|['"]$//g;
 407         $return = $val;
 408     }
 409     | /NULL/
 410     { 'NULL' }
 411
 412 !;
 413
 414 # -------------------------------------------------------------------
 415 sub parse {
 416     my ( $translator, $data ) = @_;
 417     my $parser = Parse::RecDescent->new($GRAMMAR);
 418
 419     local $::RD_TRACE  = $translator->trace ? 1 : undef;
 420     local $DEBUG       = $translator->debug;
 421
 422     unless (defined $parser) {
 423         return $translator->error("Error instantiating Parse::RecDescent ".
 424             "instance: Bad grammer");
 425     }
 426
 427     my $result = $parser->startrule($data);
 428     return $translator->error( "Parse failed." ) unless defined $result;
 429     warn Dumper( $result ) if $DEBUG;
 430
 431     my $schema = $translator->schema;
 432     my @tables = sort {
 433         $result->{ $a }->{'order'} <=> $result->{ $b }->{'order'}
 434     } keys %{ $result };
 435
 436     for my $table_name ( @tables ) {
 437         my $tdata =  $result->{ $table_name };
 438         my $table =  $schema->add_table(
 439             name  => $tdata->{'table_name'},
 440         ) or die $schema->error;
 441
 442         $table->comments( $tdata->{'comments'} );
 443
 444         my @fields = sort {
 445             $tdata->{'fields'}->{$a}->{'order'}
 446             <=>
 447             $tdata->{'fields'}->{$b}->{'order'}
 448         } keys %{ $tdata->{'fields'} };
 449
 450         for my $fname ( @fields ) {
 451             my $fdata = $tdata->{'fields'}{ $fname };
 452             my $field = $table->add_field(
 453                 name              => $fdata->{'name'},
 454                 data_type         => $fdata->{'data_type'},
 455                 size              => $fdata->{'size'},
 456                 default_value     => $fdata->{'default'},
 457                 is_auto_increment => $fdata->{'is_auto_inc'},
 458                 is_nullable       => $fdata->{'null'},
 459                 comments          => $fdata->{'comments'},
 460             ) or die $table->error;
 461
 462             $table->primary_key( $field->name ) if $fdata->{'is_primary_key'};
 463
 464 #            for my $qual ( qw[ binary unsigned zerofill list ] ) {
 465 #                if ( my $val = $fdata->{ $qual } || $fdata->{ uc $qual } ) {
 466 #                    next if ref $val eq 'ARRAY' && !@$val;
 467 #                    $field->extra( $qual, $val );
 468 #                }
 469 #            }
 470
 471 #            for my $cdata ( @{ $fdata->{'constraints'} } ) {
 472 #                next unless $cdata->{'type'} eq 'foreign_key';
 473 #                $cdata->{'fields'} ||= [ $field->name ];
 474 #                push @{ $tdata->{'constraints'} }, $cdata;
 475 #            }
 476         }
 477
 478         for my $idata ( @{ $tdata->{'indices'} || [] } ) {
 479             my $index  =  $table->add_index(
 480                 name   => $idata->{'name'},
 481                 type   => uc $idata->{'type'},
 482                 fields => $idata->{'fields'},
 483             ) or die $table->error;
 484         }
 485
 486 #        for my $cdata ( @{ $tdata->{'constraints'} || [] } ) {
 487 #            my $constraint       =  $table->add_constraint(
 488 #                name             => $cdata->{'name'},
 489 #                type             => $cdata->{'type'},
 490 #                fields           => $cdata->{'fields'},
 491 #                reference_table  => $cdata->{'reference_table'},
 492 #                reference_fields => $cdata->{'reference_fields'},
 493 #                match_type       => $cdata->{'match_type'} || '',
 494 #                on_delete        => $cdata->{'on_delete_do'},
 495 #                on_update        => $cdata->{'on_update_do'},
 496 #            ) or die $table->error;
 497 #        }
 498     }
 499
 500     return 1;
 501 }
 502
 503 1;
 504
 505 # -------------------------------------------------------------------
 506 # Where man is not nature is barren.
 507 # William Blake
 508 # -------------------------------------------------------------------
 509
 510 =pod
 511
 512 =head1 AUTHOR
 513
 514 Ken Y. Clark E<lt>kclark@cpan.orgE<gt>.
 515
 516 =head1 SEE ALSO
 517
 518 perl(1), Parse::RecDescent, SQL::Translator::Schema.
 519
 520 =cut