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