lib/SQL/Translator/Parser/Sybase.pm

   1 package SQL::Translator::Parser::Sybase;
   2
   3 =head1 NAME
   4
   5 SQL::Translator::Parser::Sybase - parser for Sybase
   6
   7 =head1 SYNOPSIS
   8
   9   use SQL::Translator::Parser::Sybase;
  10
  11 =head1 DESCRIPTION
  12
  13 Mostly parses the output of "dbschema.pl," a Perl script freely
  14 available from http://www.midsomer.org.  The parsing is not complete,
  15 however, and you would probably have much better luck using the
  16 DBI-Sybase parser included with SQL::Translator.
  17
  18 =cut
  19
  20 use strict;
  21
  22 use vars qw[ $DEBUG $VERSION $GRAMMAR @EXPORT_OK ];
  23 $VERSION = '1.59';
  24 $DEBUG   = 0 unless defined $DEBUG;
  25
  26 use Data::Dumper;
  27 use Parse::RecDescent;
  28 use Exporter;
  29 use base qw(Exporter);
  30
  31 @EXPORT_OK = qw(parse);
  32
  33 $::RD_ERRORS = 1;
  34 $::RD_WARN   = 1;
  35 $::RD_HINT   = 1;
  36
  37 $GRAMMAR = q{
  38
  39 {
  40     my ( %tables, @table_comments, $table_order );
  41 }
  42
  43 startrule : statement(s) eofile { \%tables }
  44
  45 eofile : /^\Z/
  46
  47 statement : create_table
  48     | create_procedure
  49     | create_index
  50     | create_constraint
  51     | comment
  52     | use
  53     | setuser
  54     | if
  55     | print
  56     | grant
  57     | exec
  58     | <error>
  59
  60 use : /use/i WORD GO
  61     { @table_comments = () }
  62
  63 setuser : /setuser/i NAME GO
  64
  65 if : /if/i object_not_null begin if_command end GO
  66
  67 if_command : grant
  68     | create_index
  69     | create_constraint
  70
  71 object_not_null : /object_id/i '(' ident ')' /is not null/i
  72
  73 print : /\s*/ /print/i /.*/
  74
  75 else : /else/i /.*/
  76
  77 begin : /begin/i
  78
  79 end : /end/i
  80
  81 grant : /grant/i /[^\n]*/
  82
  83 exec : exec_statement(s) GO
  84
  85 exec_statement : /exec/i /[^\n]+/
  86
  87 comment : comment_start comment_middle comment_end
  88     {
  89         my $comment = $item[2];
  90         $comment =~ s/^\s*|\s*$//mg;
  91         $comment =~ s/^\**\s*//mg;
  92         push @table_comments, $comment;
  93     }
  94
  95 comment_start : /^\s*\/\*/
  96
  97 comment_end : /\s*\*\//
  98
  99 comment_middle : m{([^*]+|\*(?!/))*}
 100
 101 #
 102 # Create table.
 103 #
 104 create_table : /create/i /table/i ident '(' create_def(s /,/) ')' lock(?) on_system(?) GO
 105     {
 106         my $table_owner = $item[3]{'owner'};
 107         my $table_name  = $item[3]{'name'};
 108
 109         if ( @table_comments ) {
 110             $tables{ $table_name }{'comments'} = [ @table_comments ];
 111             @table_comments = ();
 112         }
 113
 114         $tables{ $table_name }{'order'}  = ++$table_order;
 115         $tables{ $table_name }{'name'}   = $table_name;
 116         $tables{ $table_name }{'owner'}  = $table_owner;
 117         $tables{ $table_name }{'system'} = $item[7];
 118
 119         my $i = 0;
 120         for my $def ( @{ $item[5] } ) {
 121             if ( $def->{'supertype'} eq 'field' ) {
 122                 my $field_name = $def->{'name'};
 123                 $tables{ $table_name }{'fields'}{ $field_name } =
 124                     { %$def, order => $i };
 125                 $i++;
 126
 127                 if ( $def->{'is_primary_key'} ) {
 128                     push @{ $tables{ $table_name }{'constraints'} }, {
 129                         type   => 'primary_key',
 130                         fields => [ $field_name ],
 131                     };
 132                 }
 133             }
 134             elsif ( $def->{'supertype'} eq 'constraint' ) {
 135                 push @{ $tables{ $table_name }{'constraints'} }, $def;
 136             }
 137             else {
 138                 push @{ $tables{ $table_name }{'indices'} }, $def;
 139             }
 140         }
 141     }
 142
 143 create_constraint : /create/i constraint
 144     {
 145         @table_comments = ();
 146         push @{ $tables{ $item[2]{'table'} }{'constraints'} }, $item[2];
 147     }
 148
 149 create_index : /create/i index
 150     {
 151         @table_comments = ();
 152         push @{ $tables{ $item[2]{'table'} }{'indices'} }, $item[2];
 153     }
 154
 155 create_procedure : /create/i /procedure/i procedure_body GO
 156     {
 157         @table_comments = ();
 158     }
 159
 160 procedure_body : not_go(s)
 161
 162 not_go : /((?!go).)*/
 163
 164 create_def : field
 165     | index
 166     | constraint
 167
 168 blank : /\s*/
 169
 170 field : field_name data_type nullable(?)
 171     {
 172         $return = {
 173             supertype      => 'field',
 174             name           => $item{'field_name'},
 175             data_type      => $item{'data_type'}{'type'},
 176             size           => $item{'data_type'}{'size'},
 177             nullable       => $item[3][0],
 178 #            default        => $item{'default_val'}[0],
 179 #            is_auto_inc    => $item{'auto_inc'}[0],
 180 #            is_primary_key => $item{'primary_key'}[0],
 181         }
 182     }
 183
 184 constraint : primary_key_constraint
 185     | unique_constraint
 186
 187 field_name : WORD
 188
 189 index_name : WORD
 190
 191 table_name : WORD
 192
 193 data_type : WORD field_size(?)
 194     {
 195         $return = {
 196             type => $item[1],
 197             size => $item[2][0]
 198         }
 199     }
 200
 201 lock : /lock/i /datarows/i
 202
 203 field_type : WORD
 204
 205 field_size : '(' num_range ')' { $item{'num_range'} }
 206
 207 num_range : DIGITS ',' DIGITS
 208     { $return = $item[1].','.$item[3] }
 209                | DIGITS
 210     { $return = $item[1] }
 211
 212
 213 nullable : /not/i /null/i
 214     { $return = 0 }
 215     | /null/i
 216     { $return = 1 }
 217
 218 default_val : /default/i /(?:')?[\w\d.-]*(?:')?/
 219     { $item[2]=~s/'//g; $return=$item[2] }
 220
 221 auto_inc : /auto_increment/i { 1 }
 222
 223 primary_key_constraint : /primary/i /key/i index_name(?) parens_field_list
 224     {
 225         $return = {
 226             supertype => 'constraint',
 227             name      => $item{'index_name'}[0],
 228             type      => 'primary_key',
 229             fields    => $item[4],
 230         }
 231     }
 232
 233 unique_constraint : /unique/i clustered(?) INDEX(?) index_name(?) on_table(?) parens_field_list
 234     {
 235         $return = {
 236             supertype => 'constraint',
 237             type      => 'unique',
 238             clustered => $item[2][0],
 239             name      => $item[4][0],
 240             table     => $item[5][0],
 241             fields    => $item[6],
 242         }
 243     }
 244
 245 clustered : /clustered/i
 246     { $return = 1 }
 247     | /nonclustered/i
 248     { $return = 0 }
 249
 250 INDEX : /index/i
 251
 252 on_table : /on/i table_name
 253     { $return = $item[2] }
 254
 255 on_system : /on/i /system/i
 256     { $return = 1 }
 257
 258 index : clustered(?) INDEX index_name(?) on_table(?) parens_field_list
 259     {
 260         $return = {
 261             supertype => 'index',
 262             type      => 'normal',
 263             clustered => $item[1][0],
 264             name      => $item[3][0],
 265             table     => $item[4][0],
 266             fields    => $item[5],
 267         }
 268     }
 269
 270 parens_field_list : '(' field_name(s /,/) ')'
 271     { $item[2] }
 272
 273 ident : QUOTE(?) WORD '.' WORD QUOTE(?)
 274     { $return = { owner => $item[2], name => $item[4] } }
 275     | WORD
 276     { $return = { name  => $item[2] } }
 277
 278 GO : /^go/i
 279
 280 NAME : QUOTE(?) /\w+/ QUOTE(?)
 281     { $item[2] }
 282
 283 WORD : /[\w#]+/
 284
 285 DIGITS : /\d+/
 286
 287 COMMA : ','
 288
 289 QUOTE : /'/
 290
 291 };
 292
 293 # -------------------------------------------------------------------
 294 sub parse {
 295     my ( $translator, $data ) = @_;
 296     my $parser = Parse::RecDescent->new($GRAMMAR);
 297
 298     local $::RD_TRACE  = $translator->trace ? 1 : undef;
 299     local $DEBUG       = $translator->debug;
 300
 301     unless (defined $parser) {
 302         return $translator->error("Error instantiating Parse::RecDescent ".
 303             "instance: Bad grammer");
 304     }
 305
 306     my $result = $parser->startrule($data);
 307     return $translator->error( "Parse failed." ) unless defined $result;
 308     warn Dumper( $result ) if $DEBUG;
 309
 310     my $schema = $translator->schema;
 311     my @tables = sort {
 312         $result->{ $a }->{'order'} <=> $result->{ $b }->{'order'}
 313     } keys %{ $result };
 314
 315     for my $table_name ( @tables ) {
 316         my $tdata = $result->{ $table_name };
 317         my $table = $schema->add_table( name => $tdata->{'name'} )
 318                     or die "Can't create table '$table_name': ", $schema->error;
 319
 320         $table->comments( $tdata->{'comments'} );
 321
 322         my @fields = sort {
 323             $tdata->{'fields'}->{$a}->{'order'}
 324             <=>
 325             $tdata->{'fields'}->{$b}->{'order'}
 326         } keys %{ $tdata->{'fields'} };
 327
 328         for my $fname ( @fields ) {
 329             my $fdata = $tdata->{'fields'}{ $fname };
 330             my $field = $table->add_field(
 331                 name              => $fdata->{'name'},
 332                 data_type         => $fdata->{'data_type'},
 333                 size              => $fdata->{'size'},
 334                 default_value     => $fdata->{'default'},
 335                 is_auto_increment => $fdata->{'is_auto_inc'},
 336                 is_nullable       => $fdata->{'nullable'},
 337                 comments          => $fdata->{'comments'},
 338             ) or die $table->error;
 339
 340             $table->primary_key( $field->name ) if $fdata->{'is_primary_key'};
 341
 342             for my $qual ( qw[ binary unsigned zerofill list ] ) {
 343                 if ( my $val = $fdata->{ $qual } || $fdata->{ uc $qual } ) {
 344                     next if ref $val eq 'ARRAY' && !@$val;
 345                     $field->extra( $qual, $val );
 346                 }
 347             }
 348
 349             if ( $field->data_type =~ /(set|enum)/i && !$field->size ) {
 350                 my %extra = $field->extra;
 351                 my $longest = 0;
 352                 for my $len ( map { length } @{ $extra{'list'} || [] } ) {
 353                     $longest = $len if $len > $longest;
 354                 }
 355                 $field->size( $longest ) if $longest;
 356             }
 357
 358             for my $cdata ( @{ $fdata->{'constraints'} } ) {
 359                 next unless $cdata->{'type'} eq 'foreign_key';
 360                 $cdata->{'fields'} ||= [ $field->name ];
 361                 push @{ $tdata->{'constraints'} }, $cdata;
 362             }
 363         }
 364
 365         for my $idata ( @{ $tdata->{'indices'} || [] } ) {
 366             my $index  =  $table->add_index(
 367                 name   => $idata->{'name'},
 368                 type   => uc $idata->{'type'},
 369                 fields => $idata->{'fields'},
 370             ) or die $table->error;
 371         }
 372
 373         for my $cdata ( @{ $tdata->{'constraints'} || [] } ) {
 374             my $constraint       =  $table->add_constraint(
 375                 name             => $cdata->{'name'},
 376                 type             => $cdata->{'type'},
 377                 fields           => $cdata->{'fields'},
 378                 reference_table  => $cdata->{'reference_table'},
 379                 reference_fields => $cdata->{'reference_fields'},
 380                 match_type       => $cdata->{'match_type'} || '',
 381                 on_delete        => $cdata->{'on_delete'} || $cdata->{'on_delete_do'},
 382                 on_update        => $cdata->{'on_update'} || $cdata->{'on_update_do'},
 383             ) or die $table->error;
 384         }
 385     }
 386
 387     return 1;
 388 }
 389
 390 1;
 391
 392 # -------------------------------------------------------------------
 393 # Every hero becomes a bore at last.
 394 # Ralph Waldo Emerson
 395 # -------------------------------------------------------------------
 396
 397 =pod
 398
 399 =head1 AUTHOR
 400
 401 Ken Y. Clark E<lt>kclark@cpan.orgE<gt>.
 402
 403 =head1 SEE ALSO
 404
 405 SQL::Translator, SQL::Translator::Parser::DBI, L<http://www.midsomer.org/>.
 406
 407 =cut