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 use warnings;
  22
  23 our ( $DEBUG, $GRAMMAR, @EXPORT_OK );
  24 our $VERSION = '1.59';
  25 $DEBUG   = 0 unless defined $DEBUG;
  26
  27 use Data::Dumper;
  28 use Parse::RecDescent;
  29 use Exporter;
  30 use base qw(Exporter);
  31
  32 @EXPORT_OK = qw(parse);
  33
  34 $::RD_ERRORS = 1;
  35 $::RD_WARN   = 1;
  36 $::RD_HINT   = 1;
  37
  38 $GRAMMAR = q{
  39
  40 {
  41     my ( %tables, @table_comments, $table_order );
  42 }
  43
  44 startrule : statement(s) eofile { \%tables }
  45
  46 eofile : /^\Z/
  47
  48 statement : create_table
  49     | create_procedure
  50     | create_index
  51     | create_constraint
  52     | comment
  53     | use
  54     | setuser
  55     | if
  56     | print
  57     | grant
  58     | exec
  59     | <error>
  60
  61 use : /use/i WORD GO
  62     { @table_comments = () }
  63
  64 setuser : /setuser/i NAME GO
  65
  66 if : /if/i object_not_null begin if_command end GO
  67
  68 if_command : grant
  69     | create_index
  70     | create_constraint
  71
  72 object_not_null : /object_id/i '(' ident ')' /is not null/i
  73
  74 print : /\s*/ /print/i /.*/
  75
  76 else : /else/i /.*/
  77
  78 begin : /begin/i
  79
  80 end : /end/i
  81
  82 grant : /grant/i /[^\n]*/
  83
  84 exec : exec_statement(s) GO
  85
  86 exec_statement : /exec/i /[^\n]+/
  87
  88 comment : comment_start comment_middle comment_end
  89     {
  90         my $comment = $item[2];
  91         $comment =~ s/^\s*|\s*$//mg;
  92         $comment =~ s/^\**\s*//mg;
  93         push @table_comments, $comment;
  94     }
  95
  96 comment_start : /^\s*\/\*/
  97
  98 comment_end : /\s*\*\//
  99
 100 comment_middle : m{([^*]+|\*(?!/))*}
 101
 102 #
 103 # Create table.
 104 #
 105 create_table : /create/i /table/i ident '(' create_def(s /,/) ')' lock(?) on_system(?) GO
 106     {
 107         my $table_owner = $item[3]{'owner'};
 108         my $table_name  = $item[3]{'name'};
 109
 110         if ( @table_comments ) {
 111             $tables{ $table_name }{'comments'} = [ @table_comments ];
 112             @table_comments = ();
 113         }
 114
 115         $tables{ $table_name }{'order'}  = ++$table_order;
 116         $tables{ $table_name }{'name'}   = $table_name;
 117         $tables{ $table_name }{'owner'}  = $table_owner;
 118         $tables{ $table_name }{'system'} = $item[7];
 119
 120         my $i = 0;
 121         for my $def ( @{ $item[5] } ) {
 122             if ( $def->{'supertype'} eq 'field' ) {
 123                 my $field_name = $def->{'name'};
 124                 $tables{ $table_name }{'fields'}{ $field_name } =
 125                     { %$def, order => $i };
 126                 $i++;
 127
 128                 if ( $def->{'is_primary_key'} ) {
 129                     push @{ $tables{ $table_name }{'constraints'} }, {
 130                         type   => 'primary_key',
 131                         fields => [ $field_name ],
 132                     };
 133                 }
 134             }
 135             elsif ( $def->{'supertype'} eq 'constraint' ) {
 136                 push @{ $tables{ $table_name }{'constraints'} }, $def;
 137             }
 138             else {
 139                 push @{ $tables{ $table_name }{'indices'} }, $def;
 140             }
 141         }
 142     }
 143
 144 create_constraint : /create/i constraint
 145     {
 146         @table_comments = ();
 147         push @{ $tables{ $item[2]{'table'} }{'constraints'} }, $item[2];
 148     }
 149
 150 create_index : /create/i index
 151     {
 152         @table_comments = ();
 153         push @{ $tables{ $item[2]{'table'} }{'indices'} }, $item[2];
 154     }
 155
 156 create_procedure : /create/i /procedure/i procedure_body GO
 157     {
 158         @table_comments = ();
 159     }
 160
 161 procedure_body : not_go(s)
 162
 163 not_go : /((?!go).)*/
 164
 165 create_def : field
 166     | index
 167     | constraint
 168
 169 blank : /\s*/
 170
 171 field : field_name data_type nullable(?)
 172     {
 173         $return = {
 174             supertype      => 'field',
 175             name           => $item{'field_name'},
 176             data_type      => $item{'data_type'}{'type'},
 177             size           => $item{'data_type'}{'size'},
 178             nullable       => $item[3][0],
 179 #            default        => $item{'default_val'}[0],
 180 #            is_auto_inc    => $item{'auto_inc'}[0],
 181 #            is_primary_key => $item{'primary_key'}[0],
 182         }
 183     }
 184
 185 constraint : primary_key_constraint
 186     | unique_constraint
 187
 188 field_name : WORD
 189
 190 index_name : WORD
 191
 192 table_name : WORD
 193
 194 data_type : WORD field_size(?)
 195     {
 196         $return = {
 197             type => $item[1],
 198             size => $item[2][0]
 199         }
 200     }
 201
 202 lock : /lock/i /datarows/i
 203
 204 field_type : WORD
 205
 206 field_size : '(' num_range ')' { $item{'num_range'} }
 207
 208 num_range : DIGITS ',' DIGITS
 209     { $return = $item[1].','.$item[3] }
 210                | DIGITS
 211     { $return = $item[1] }
 212
 213
 214 nullable : /not/i /null/i
 215     { $return = 0 }
 216     | /null/i
 217     { $return = 1 }
 218
 219 default_val : /default/i /(?:')?[\w\d.-]*(?:')?/
 220     { $item[2]=~s/'//g; $return=$item[2] }
 221
 222 auto_inc : /auto_increment/i { 1 }
 223
 224 primary_key_constraint : /primary/i /key/i index_name(?) parens_field_list
 225     {
 226         $return = {
 227             supertype => 'constraint',
 228             name      => $item{'index_name'}[0],
 229             type      => 'primary_key',
 230             fields    => $item[4],
 231         }
 232     }
 233
 234 unique_constraint : /unique/i clustered(?) INDEX(?) index_name(?) on_table(?) parens_field_list
 235     {
 236         $return = {
 237             supertype => 'constraint',
 238             type      => 'unique',
 239             clustered => $item[2][0],
 240             name      => $item[4][0],
 241             table     => $item[5][0],
 242             fields    => $item[6],
 243         }
 244     }
 245
 246 clustered : /clustered/i
 247     { $return = 1 }
 248     | /nonclustered/i
 249     { $return = 0 }
 250
 251 INDEX : /index/i
 252
 253 on_table : /on/i table_name
 254     { $return = $item[2] }
 255
 256 on_system : /on/i /system/i
 257     { $return = 1 }
 258
 259 index : clustered(?) INDEX index_name(?) on_table(?) parens_field_list
 260     {
 261         $return = {
 262             supertype => 'index',
 263             type      => 'normal',
 264             clustered => $item[1][0],
 265             name      => $item[3][0],
 266             table     => $item[4][0],
 267             fields    => $item[5],
 268         }
 269     }
 270
 271 parens_field_list : '(' field_name(s /,/) ')'
 272     { $item[2] }
 273
 274 ident : QUOTE(?) WORD '.' WORD QUOTE(?)
 275     { $return = { owner => $item[2], name => $item[4] } }
 276     | WORD
 277     { $return = { name  => $item[2] } }
 278
 279 GO : /^go/i
 280
 281 NAME : QUOTE(?) /\w+/ QUOTE(?)
 282     { $item[2] }
 283
 284 WORD : /[\w#]+/
 285
 286 DIGITS : /\d+/
 287
 288 COMMA : ','
 289
 290 QUOTE : /'/
 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