[dbsrgits/SQL-Translator.git] / lib / SQL / Translator / Parser / PostgreSQL.pm

package SQL::Translator::Parser::PostgreSQL;

# -------------------------------------------------------------------
# $Id: PostgreSQL.pm,v 1.2 2003-02-25 01:01:29 allenday Exp $
# -------------------------------------------------------------------
# Copyright (C) 2003 Ken Y. Clark <kclark@cpan.org>,
#                    darren chamberlain <darren@cpan.org>,
#                    Chris Mungall <cjm@fruitfly.org>
#
# This program is free software; you can redistribute it and/or
# modify it under the terms of the GNU General Public License as
# published by the Free Software Foundation; version 2.
#
# This program is distributed in the hope that it will be useful, but
# WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
# General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# along with this program; if not, write to the Free Software
# Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA
# 02111-1307  USA
# -------------------------------------------------------------------

=head1 NAME

SQL::Translator::Parser::PostgreSQL - parser for PostgreSQL

=head1 SYNOPSIS

  use SQL::Translator;
  use SQL::Translator::Parser::PostgreSQL;

  my $translator = SQL::Translator->new;
  $translator->parser("SQL::Translator::Parser::PostgreSQL");

=head1 DESCRIPTION

The grammar is influenced heavily by Tim Bunce's "mysql2ora" grammar.

=cut

use strict;
use vars qw[ $DEBUG $VERSION $GRAMMAR @EXPORT_OK ];
$VERSION = sprintf "%d.%02d", q$Revision: 1.2 $ =~ /(\d+)\.(\d+)/;
$DEBUG   = 0 unless defined $DEBUG;

use Data::Dumper;
use Parse::RecDescent;
use Exporter;
use base qw(Exporter);

@EXPORT_OK = qw(parse);

# Enable warnings within the Parse::RecDescent module.
$::RD_ERRORS = 1; # Make sure the parser dies when it encounters an error
$::RD_WARN   = 1; # Enable warnings. This will warn on unused rules &c.
$::RD_HINT   = 1; # Give out hints to help fix problems.

my $parser; # should we do this?  There's no programmic way to 
            # change the grammar, so I think this is safe.

$GRAMMAR = q!

{ our ( %tables, $table_order ) }

startrule : statement(s) { \%tables }

statement : comment
  | drop
  | create
  | <error>

drop : /drop/i WORD(s) ';'

create : create_table table_name '(' create_definition(s /,/) ')' table_option(s?) ';'
  {
   my $table_name                       = $item{'table_name'};
   $tables{ $table_name }{'order'}      = ++$table_order;
   $tables{ $table_name }{'table_name'} = $table_name;

   my $i = 1;
   for my $definition ( @{ $item[4] } ) {
	 if ( $definition->{'type'} eq 'field' ) {
	   my $field_name = $definition->{'name'};
	   $tables{ $table_name }{'fields'}{ $field_name } = 
		 { %$definition, order => $i };
	   $i++;
				
	   if ( $definition->{'is_primary_key'} ) {
		 push @{ $tables{ $table_name }{'indices'} },
		   {
			type   => 'primary_key',
			fields => [ $field_name ],
		   }
			 ;
	   }
	 }
	 else {
	   push @{ $tables{ $table_name }{'indices'} },
		 $definition;
	 }
   }

   for my $opt ( @{ $item{'table_option'} } ) {
	 if ( my ( $key, $val ) = each %$opt ) {
	   $tables{ $table_name }{'table_options'}{ $key } = $val;
	 }
   }
  }

  create : /CREATE/i unique(?) /(INDEX|KEY)/i index_name /on/i table_name '(' field_name(s /,/) ')' ';'
    {
        push @{ $tables{ $item{'table_name'} }{'indices'} },
            {
                name   => $item[4],
                type   => $item[2] ? 'unique' : 'normal',
                fields => $item[8],
            }
        ;
    }

create_definition : index
    | field
    | <error>

comment : /^\s*(?:#|-{2}).*\n/

blank : /\s*/

field : field_name data_type field_qualifier(s?)
    {
        my %qualifiers = map { %$_ } @{ $item{'field_qualifier'} || [] };
        my $null = defined $item{'not_null'} ? $item{'not_null'} : 1;
        delete $qualifiers{'not_null'};
        if ( my @type_quals = @{ $item{'data_type'}{'qualifiers'} || [] } ) {
            $qualifiers{ $_ } = 1 for @type_quals;
        }

        $return = { 
            type           => 'field',
            name           => $item{'field_name'}, 
            data_type      => $item{'data_type'}{'type'},
            size           => $item{'data_type'}{'size'},
            list           => $item{'data_type'}{'list'},
            null           => $null,
            %qualifiers,
        } 
    }
    | <error>

field_qualifier : not_null
    { 
        $return = { 
             null => $item{'not_null'},
        } 
    }

field_qualifier : default_val
    { 
        $return = { 
             default => $item{'default_val'},
        } 
    }

field_qualifier : auto_inc
    { 
        $return = { 
             is_auto_inc => $item{'auto_inc'},
        } 
    }

field_qualifier : ',' primary_key '(' field_name ')'
    { 
        $return = { 
             is_primary_key => $item{'primary_key'},
        } 
    }

field_qualifier : ',' foreign_key '(' field_name ')' foreign_key_reference foreign_table_name '(' foreign_field_name ')'
    { 
        $return = {
             is_foreign_key => $item{'foreign_key'},
			 foreign_table => $item{'foreign_table_name'},
			 foreign_field => $item{'foreign_field_name'},
			 name => $item{'field_name'},
        }
    }

field_qualifier : unsigned
    { 
        $return = { 
             is_unsigned => $item{'unsigned'},
        } 
    }

index : primary_key_index
    | unique_index
    | fulltext_index
    | normal_index

table_name   : WORD

foreign_table_name   : WORD

field_name   : WORD

foreign_field_name   : WORD

index_name   : WORD

data_type    : WORD parens_value_list(s?) type_qualifier(s?)
    { 
        my $type = $item[1];

        my $size; # field size, applicable only to non-set fields
        my $list; # set list, applicable only to sets (duh)


        if(uc($type) =~ /^SERIAL$/){
            $type = 'int';
        } elsif ( uc($type) =~ /^(SET|ENUM)$/ ) {
            $size = undef;
            $list = $item[2][0];
        }
        else {
            $size = $item[2][0];
            $list = [];
        }

        if(uc($type) =~ /^VARCHAR$/ and not defined($size)){ $size = [255] }

        $return        = { 
            type       => $type,
            size       => $size,
            list       => $list,
            qualifiers => $item[3],
        } 
    }

parens_value_list : '(' VALUE(s /,/) ')'
    { $item[2] }

type_qualifier : /(BINARY|UNSIGNED|ZEROFILL)/i
    { lc $item[1] }

field_type   : WORD

field_size   : '(' num_range ')' { $item{'num_range'} }

num_range    : DIGITS ',' DIGITS
    { $return = $item[1].','.$item[3] }
    | DIGITS
    { $return = $item[1] }

create_table : /create/i /table/i

create_index : /create/i /index/i

not_null     : /not/i /null/i { $return = 0 }

unsigned     : /unsigned/i { $return = 0 }

default_val  : /default/i /(?:')?[\w\d.-]*(?:')?/ 
    { 
        $item[2] =~ s/'//g; 
        $return  =  $item[2];
    }

auto_inc : /auto_increment/i { 1 } #see data_type

primary_key : /primary/i /key/i { 1 }

foreign_key : /foreign/i /key/i { 1 }

foreign_key_reference : /references/i { 1 }

primary_key_index : primary_key index_name(?) '(' field_name(s /,/) ')'
    { 
        $return    = { 
            name   => $item{'index_name'}[0],
            type   => 'primary_key',
            fields => $item[4],
        } 
    }

normal_index : key index_name(?) '(' name_with_opt_paren(s /,/) ')'
    { 
        $return    = { 
            name   => $item{'index_name'}[0],
            type   => 'normal',
            fields => $item[4],
        } 
    }

unique_index : unique key(?) index_name(?) '(' name_with_opt_paren(s /,/) ')'
    { 
        $return    = { 
            name   => $item{'index_name'}[0],
            type   => 'unique',
            fields => $item[5],
        } 
    }

fulltext_index : fulltext key(?) index_name(?) '(' name_with_opt_paren(s /,/) ')'
    { 
        $return    = { 
            name   => $item{'index_name'}[0],
            type   => 'fulltext',
            fields => $item[5],
        } 
    }

name_with_opt_paren : NAME parens_value_list(s?)
    { $item[2][0] ? "$item[1]($item[2][0][0])" : $item[1] }

fulltext : /fulltext/i { 1 }

unique : /unique/i { 1 }

key : /key/i | /index/i

table_option : /[^\s;]*/ 
    { 
        $return = { split /=/, $item[1] }
    }

WORD : /\w+/

DIGITS : /\d+/

COMMA : ','

NAME    : "`" /\w+/ "`"
    { $item[2] }
    | /\w+/
    { $item[1] }

VALUE   : /[-+]?\.?\d+(?:[eE]\d+)?/
    { $item[1] }
    | /'.*?'/   # XXX doesn't handle embedded quotes
    { $item[1] }
    | /NULL/
    { 'NULL' }

!;

# -------------------------------------------------------------------
sub parse {
    my ( $translator, $data ) = @_;
    $parser ||= Parse::RecDescent->new($GRAMMAR);

    $::RD_TRACE  = $translator->trace ? 1 : undef;
    $DEBUG       = $translator->debug;

    unless (defined $parser) {
        return $translator->error("Error instantiating Parse::RecDescent ".
            "instance: Bad grammer");
    }

    my $result = $parser->startrule($data);
    die "Parse failed.\n" unless defined $result;
    warn Dumper($result) if $DEBUG;
    return $result;
}

1;

#-----------------------------------------------------
# Where man is not nature is barren.
# William Blake
#-----------------------------------------------------

=pod

=head1 AUTHOR

Ken Y. Clark E<lt>kclark@cpan.orgE<gt>,
Chris Mungall

=head1 SEE ALSO

perl(1), Parse::RecDescent.

=cut
Commit	Line	Data
84012a55	1	package SQL::Translator::Parser::PostgreSQL;
4422e22a	2
4422e22a	3	# -------------------------------------------------------------------
ba1a1626	4	# $Id: PostgreSQL.pm,v 1.2 2003-02-25 01:01:29 allenday Exp $
4422e22a	5	# -------------------------------------------------------------------
	6	# Copyright (C) 2003 Ken Y. Clark <kclark@cpan.org>,
	7	# darren chamberlain <darren@cpan.org>,
	8	# Chris Mungall <cjm@fruitfly.org>
	9	#
	10	# This program is free software; you can redistribute it and/or
	11	# modify it under the terms of the GNU General Public License as
	12	# published by the Free Software Foundation; version 2.
	13	#
	14	# This program is distributed in the hope that it will be useful, but
	15	# WITHOUT ANY WARRANTY; without even the implied warranty of
	16	# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
	17	# General Public License for more details.
	18	#
	19	# You should have received a copy of the GNU General Public License
	20	# along with this program; if not, write to the Free Software
	21	# Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA
	22	# 02111-1307 USA
	23	# -------------------------------------------------------------------
	24
	25	=head1 NAME
	26
84012a55	27	SQL::Translator::Parser::PostgreSQL - parser for PostgreSQL
4422e22a	28
	29	=head1 SYNOPSIS
	30
	31	use SQL::Translator;
84012a55	32	use SQL::Translator::Parser::PostgreSQL;
4422e22a	33
4422e22a	34	my $translator = SQL::Translator->new;
84012a55	35	$translator->parser("SQL::Translator::Parser::PostgreSQL");
4422e22a	36
	37	=head1 DESCRIPTION
	38
	39	The grammar is influenced heavily by Tim Bunce's "mysql2ora" grammar.
	40
	41	=cut
	42
	43	use strict;
	44	use vars qw[ $DEBUG $VERSION $GRAMMAR @EXPORT_OK ];
ba1a1626	45	$VERSION = sprintf "%d.%02d", q$Revision: 1.2 $ =~ /(\d+)\.(\d+)/;
4422e22a	46	$DEBUG = 0 unless defined $DEBUG;
	47
	48	use Data::Dumper;
	49	use Parse::RecDescent;
	50	use Exporter;
	51	use base qw(Exporter);
	52
	53	@EXPORT_OK = qw(parse);
	54
	55	# Enable warnings within the Parse::RecDescent module.
	56	$::RD_ERRORS = 1; # Make sure the parser dies when it encounters an error
	57	$::RD_WARN = 1; # Enable warnings. This will warn on unused rules &c.
	58	$::RD_HINT = 1; # Give out hints to help fix problems.
	59
	60	my $parser; # should we do this? There's no programmic way to
	61	# change the grammar, so I think this is safe.
	62
	63	$GRAMMAR = q!
	64
	65	{ our ( %tables, $table_order ) }
	66
	67	startrule : statement(s) { \%tables }
	68
	69	statement : comment
	70	\| drop
	71	\| create
	72	\| <error>
	73
	74	drop : /drop/i WORD(s) ';'
	75
ba1a1626	76	create : create_table table_name '(' create_definition(s /,/) ')' table_option(s?) ';'
4422e22a	77	{
	78	my $table_name = $item{'table_name'};
	79	$tables{ $table_name }{'order'} = ++$table_order;
	80	$tables{ $table_name }{'table_name'} = $table_name;
	81
	82	my $i = 1;
	83	for my $definition ( @{ $item[4] } ) {
	84	if ( $definition->{'type'} eq 'field' ) {
	85	my $field_name = $definition->{'name'};
	86	$tables{ $table_name }{'fields'}{ $field_name } =
	87	{ %$definition, order => $i };
	88	$i++;
	89
	90	if ( $definition->{'is_primary_key'} ) {
	91	push @{ $tables{ $table_name }{'indices'} },
	92	{
	93	type => 'primary_key',
	94	fields => [ $field_name ],
	95	}
	96	;
	97	}
	98	}
	99	else {
	100	push @{ $tables{ $table_name }{'indices'} },
	101	$definition;
	102	}
	103	}
	104
	105	for my $opt ( @{ $item{'table_option'} } ) {
	106	if ( my ( $key, $val ) = each %$opt ) {
	107	$tables{ $table_name }{'table_options'}{ $key } = $val;
	108	}
	109	}
	110	}
	111
	112	create : /CREATE/i unique(?) /(INDEX\|KEY)/i index_name /on/i table_name '(' field_name(s /,/) ')' ';'
	113	{
	114	push @{ $tables{ $item{'table_name'} }{'indices'} },
	115	{
	116	name => $item[4],
	117	type => $item[2] ? 'unique' : 'normal',
	118	fields => $item[8],
	119	}
	120	;
	121	}
	122
	123	create_definition : index
	124	\| field
	125	\| <error>
	126
	127	comment : /^\s(?:#\|-{2}).\n/
	128
	129	blank : /\s*/
	130
	131	field : field_name data_type field_qualifier(s?)
	132	{
	133	my %qualifiers = map { %$_ } @{ $item{'field_qualifier'} \|\| [] };
	134	my $null = defined $item{'not_null'} ? $item{'not_null'} : 1;
	135	delete $qualifiers{'not_null'};
	136	if ( my @type_quals = @{ $item{'data_type'}{'qualifiers'} \|\| [] } ) {
	137	$qualifiers{ $_ } = 1 for @type_quals;
	138	}
	139
	140	$return = {
141	type => 'field',
142	name => $item{'field_name'},
143	data_type => $item{'data_type'}{'type'},
144	size => $item{'data_type'}{'size'},
145	list => $item{'data_type'}{'list'},
146	null => $null,
147	%qualifiers,
148	}
149	}
150	\| <error>
151
152	field_qualifier : not_null
153	{
154	$return = {
155	null => $item{'not_null'},
156	}
157	}
158
159	field_qualifier : default_val
160	{
161	$return = {
162	default => $item{'default_val'},
163	}
164	}
165
166	field_qualifier : auto_inc
167	{
168	$return = {
169	is_auto_inc => $item{'auto_inc'},
170	}
171	}
172
173	field_qualifier : ',' primary_key '(' field_name ')'
174	{
175	$return = {
176	is_primary_key => $item{'primary_key'},
177	}
178	}
179
180	field_qualifier : ',' foreign_key '(' field_name ')' foreign_key_reference foreign_table_name '(' foreign_field_name ')'
181	{
182	$return = {
183	is_foreign_key => $item{'foreign_key'},
184	foreign_table => $item{'foreign_table_name'},
185	foreign_field => $item{'foreign_field_name'},
186	name => $item{'field_name'},
ba1a1626	187	}
4422e22a	188	}
	189
	190	field_qualifier : unsigned
	191	{
	192	$return = {
	193	is_unsigned => $item{'unsigned'},
	194	}
	195	}
	196
	197	index : primary_key_index
	198	\| unique_index
	199	\| fulltext_index
	200	\| normal_index
	201
	202	table_name : WORD
	203
	204	foreign_table_name : WORD
	205
	206	field_name : WORD
	207
	208	foreign_field_name : WORD
	209
	210	index_name : WORD
	211
	212	data_type : WORD parens_value_list(s?) type_qualifier(s?)
	213	{
	214	my $type = $item[1];
ba1a1626	215
4422e22a	216	my $size; # field size, applicable only to non-set fields
	217	my $list; # set list, applicable only to sets (duh)
	218
ba1a1626	219
	220	if(uc($type) =~ /^SERIAL$/){
	221	$type = 'int';
	222	} elsif ( uc($type) =~ /^(SET\|ENUM)$/ ) {
4422e22a	223	$size = undef;
	224	$list = $item[2][0];
	225	}
	226	else {
	227	$size = $item[2][0];
	228	$list = [];
	229	}
	230
ba1a1626	231	if(uc($type) =~ /^VARCHAR$/ and not defined($size)){ $size = [255] }
ba1a1626	232
4422e22a	233	$return = {
	234	type => $type,
	235	size => $size,
	236	list => $list,
	237	qualifiers => $item[3],
	238	}
	239	}
	240
	241	parens_value_list : '(' VALUE(s /,/) ')'
	242	{ $item[2] }
	243
	244	type_qualifier : /(BINARY\|UNSIGNED\|ZEROFILL)/i
	245	{ lc $item[1] }
	246
	247	field_type : WORD
	248
	249	field_size : '(' num_range ')' { $item{'num_range'} }
	250
	251	num_range : DIGITS ',' DIGITS
	252	{ $return = $item[1].','.$item[3] }
	253	\| DIGITS
	254	{ $return = $item[1] }
	255
	256	create_table : /create/i /table/i
	257
	258	create_index : /create/i /index/i
	259
	260	not_null : /not/i /null/i { $return = 0 }
	261
	262	unsigned : /unsigned/i { $return = 0 }
	263
	264	default_val : /default/i /(?:')?[\w\d.-]*(?:')?/
	265	{
	266	$item[2] =~ s/'//g;
	267	$return = $item[2];
	268	}
	269
ba1a1626	270	auto_inc : /auto_increment/i { 1 } #see data_type
4422e22a	271
	272	primary_key : /primary/i /key/i { 1 }
	273
	274	foreign_key : /foreign/i /key/i { 1 }
	275
	276	foreign_key_reference : /references/i { 1 }
	277
	278	primary_key_index : primary_key index_name(?) '(' field_name(s /,/) ')'
	279	{
	280	$return = {
	281	name => $item{'index_name'}[0],
	282	type => 'primary_key',
	283	fields => $item[4],
	284	}
	285	}
	286
	287	normal_index : key index_name(?) '(' name_with_opt_paren(s /,/) ')'
	288	{
	289	$return = {
	290	name => $item{'index_name'}[0],
	291	type => 'normal',
	292	fields => $item[4],
	293	}
	294	}
	295
	296	unique_index : unique key(?) index_name(?) '(' name_with_opt_paren(s /,/) ')'
	297	{
	298	$return = {
	299	name => $item{'index_name'}[0],
	300	type => 'unique',
	301	fields => $item[5],
	302	}
	303	}
	304
	305	fulltext_index : fulltext key(?) index_name(?) '(' name_with_opt_paren(s /,/) ')'
	306	{
	307	$return = {
	308	name => $item{'index_name'}[0],
	309	type => 'fulltext',
	310	fields => $item[5],
	311	}
	312	}
	313
	314	name_with_opt_paren : NAME parens_value_list(s?)
	315	{ $item[2][0] ? "$item[1]($item[2][0][0])" : $item[1] }
	316
	317	fulltext : /fulltext/i { 1 }
	318
	319	unique : /unique/i { 1 }
	320
	321	key : /key/i \| /index/i
	322
	323	table_option : /[^\s;]*/
	324	{
	325	$return = { split /=/, $item[1] }
	326	}
	327
	328	WORD : /\w+/
	329
	330	DIGITS : /\d+/
	331
	332	COMMA : ','
	333
	334	NAME : "`" /\w+/ "`"
335	{ $item[2] }
336	\| /\w+/
337	{ $item[1] }
338
339	VALUE : /[-+]?\.?\d+(?:[eE]\d+)?/
340	{ $item[1] }
341	\| /'.*?'/ # XXX doesn't handle embedded quotes
342	{ $item[1] }
343	\| /NULL/
344	{ 'NULL' }
345
346	!;
347
348	# -------------------------------------------------------------------
349	sub parse {
350	my ( $translator, $data ) = @_;
351	$parser \|\|= Parse::RecDescent->new($GRAMMAR);
352
353	$::RD_TRACE = $translator->trace ? 1 : undef;
354	$DEBUG = $translator->debug;
355
356	unless (defined $parser) {
357	return $translator->error("Error instantiating Parse::RecDescent ".
358	"instance: Bad grammer");
359	}
360
361	my $result = $parser->startrule($data);
362	die "Parse failed.\n" unless defined $result;
363	warn Dumper($result) if $DEBUG;
364	return $result;
365	}
366
367	1;
368
369	#-----------------------------------------------------
370	# Where man is not nature is barren.
371	# William Blake
372	#-----------------------------------------------------
373
374	=pod
375
376	=head1 AUTHOR
377
378	Ken Y. Clark E<lt>kclark@cpan.orgE<gt>,
379	Chris Mungall
380
381	=head1 SEE ALSO
382
383	perl(1), Parse::RecDescent.
384
385	=cut