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

package SQL::Translator::Producer::PostgreSQL;

# -------------------------------------------------------------------
# $Id: PostgreSQL.pm,v 1.3 2002-11-26 03:59:58 kycl4rk Exp $
# -------------------------------------------------------------------
# Copyright (C) 2002 Ken Y. Clark <kclark@cpan.org>,
#                    darren chamberlain <darren@cpan.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::Producer::PostgreSQL - PostgreSQL producer for SQL::Translator

=cut

use strict;
use vars qw[ $DEBUG $WARN $VERSION ];
$VERSION = sprintf "%d.%02d", q$Revision: 1.3 $ =~ /(\d+)\.(\d+)/;
$DEBUG = 1 unless defined $DEBUG;

use Data::Dumper;

my %translate  = (
    #
    # MySQL types
    #
    bigint     => 'bigint',
    double     => 'double precision',
    decimal    => 'decimal',
    float      => 'double precision',
    int        => 'integer',
    mediumint  => 'integer',
    smallint   => 'smallint',
    tinyint    => 'smallint',
    char       => 'char',
    varchar    => 'varchar',
    longtext   => 'text',
    mediumtext => 'text',
    text       => 'text',
    tinytext   => 'text',
    tinyblob   => 'bytea',
    blob       => 'bytea',
    mediumblob => 'bytea',
    longblob   => 'bytea',
    enum       => 'varchar',
    set        => 'varchar',
    date       => 'date',
    datetime   => 'timestamp',
    time       => 'date',
    timestamp  => 'timestamp',
    year       => 'date',

    #
    # Oracle types
    #
    number     => 'integer',
    char       => 'char',
    varchar2   => 'varchar',
    long       => 'text',
    CLOB       => 'bytea',
    date       => 'date',

    #
    # Sybase types
    #
    int        => 'integer',
    money      => 'money',
    varchar    => 'varchar',
    datetime   => 'timestamp',
    text       => 'text',
    real       => 'double precision',
    comment    => 'text',
    bit        => 'bit',
    tinyint    => 'smallint',
    float      => 'double precision',
);

my %reserved = map { $_, 1 } qw[
    ALL ANALYSE ANALYZE AND ANY AS ASC 
    BETWEEN BINARY BOTH
    CASE CAST CHECK COLLATE COLUMN CONSTRAINT CROSS
    CURRENT_DATE CURRENT_TIME CURRENT_TIMESTAMP CURRENT_USER 
    DEFAULT DEFERRABLE DESC DISTINCT DO
    ELSE END EXCEPT
    FALSE FOR FOREIGN FREEZE FROM FULL 
    GROUP HAVING 
    ILIKE IN INITIALLY INNER INTERSECT INTO IS ISNULL 
    JOIN LEADING LEFT LIKE LIMIT 
    NATURAL NEW NOT NOTNULL NULL
    OFF OFFSET OLD ON ONLY OR ORDER OUTER OVERLAPS
    PRIMARY PUBLIC REFERENCES RIGHT 
    SELECT SESSION_USER SOME TABLE THEN TO TRAILING TRUE 
    UNION UNIQUE USER USING VERBOSE WHEN WHERE
];

my $max_id_length    = 30;
my %used_identifiers = ();
my %global_names;
my %unreserve;
my %truncated;

=pod

=head1 PostgreSQL Create Table Syntax

  CREATE [ [ LOCAL ] { TEMPORARY | TEMP } ] TABLE table_name (
      { column_name data_type [ DEFAULT default_expr ] [ column_constraint [, ... ] ]
      | table_constraint }  [, ... ]
  )
  [ INHERITS ( parent_table [, ... ] ) ]
  [ WITH OIDS | WITHOUT OIDS ]

where column_constraint is:

  [ CONSTRAINT constraint_name ]
  { NOT NULL | NULL | UNIQUE | PRIMARY KEY |
    CHECK (expression) |
    REFERENCES reftable [ ( refcolumn ) ] [ MATCH FULL | MATCH PARTIAL ]
      [ ON DELETE action ] [ ON UPDATE action ] }
  [ DEFERRABLE | NOT DEFERRABLE ] [ INITIALLY DEFERRED | INITIALLY IMMEDIATE ]

and table_constraint is:

  [ CONSTRAINT constraint_name ]
  { UNIQUE ( column_name [, ... ] ) |
    PRIMARY KEY ( column_name [, ... ] ) |
    CHECK ( expression ) |
    FOREIGN KEY ( column_name [, ... ] ) REFERENCES reftable [ ( refcolumn [, ... ] ) ]
      [ MATCH FULL | MATCH PARTIAL ] [ ON DELETE action ] [ ON UPDATE action ] }
  [ DEFERRABLE | NOT DEFERRABLE ] [ INITIALLY DEFERRED | INITIALLY IMMEDIATE ]

=cut

# -------------------------------------------------------------------
sub produce {
    my ( $translator, $data ) = @_;
    $DEBUG                    = $translator->debug;
    $WARN                     = $translator->show_warnings;
    my $no_comments           = $translator->no_comments;
    my $add_drop_table        = $translator->add_drop_table;

    my $create;
    unless ( $no_comments ) {
        $create .=  sprintf 
            "--\n-- Created by %s\n-- Created on %s\n--\n\n",
            __PACKAGE__, scalar localtime;
    }

    for my $table ( 
        map  { $_->[1] }
        sort { $a->[0] <=> $b->[0] }
        map  { [ $_->{'order'}, $_ ] }
        values %$data
   ) {
        my $table_name = $table->{'table_name'};
        my @fields     = 
            map  { $_->[1] }
            sort { $a->[0] <=> $b->[0] }
            map  { [ $_->{'order'}, $_ ] }
            values %{ $table->{'fields'} };

        $create .= "--\n-- Table: $table_name\n--\n" unless $no_comments;
        $create  = "DROP TABLE $table_name;\n" if $add_drop_table;
        $create .= "CREATE TABLE $table_name (\n";

        #
        # Fields
        #
        my %field_name_scope;
        my @field_statements;
        for my $field ( @fields ) {
            my @fdata = ("", $field);

            my $field_name    = mk_name(
                $field->{'name'}, '', \%field_name_scope, 1 
            );
            my $field_name_ur = unreserve( $field_name, $table_name );
            my $field_str     = $field_name_ur;

            # data type and size
            push @fdata, sprintf "%s%s", 
                $field->{'data_type'},
                ( defined $field->{'size'} ) 
                    ? "($field->{'size'})" : '';

            # Null?
            push @fdata, "NOT NULL" unless $field->{'null'};

            # Default?  XXX Need better quoting!
            my $default = $field->{'default'};
            if ( defined $default ) {
                push @fdata, "DEFAULT '$default'";
#                if (int $default eq "$default") {
#                    push @fdata, "DEFAULT $default";
#                } else {
#                    push @fdata, "DEFAULT '$default'";
#                }
            }

            # auto_increment?
            push @fdata, "auto_increment" if $field->{'is_auto_inc'};

            # primary key?
            push @fdata, "PRIMARY KEY" if $field->{'is_primary_key'};

            push @field_statements, join( " ", @fdata );

        }
        $create .= join( ",\n", @field_statements );

        #
        # Other keys
        #
        my @indices = @{ $table->{'indices'} || [] };
        for ( my $i = 0; $i <= $#indices; $i++ ) {
            $create .= ",\n";
            my $key = $indices[$i];
            my ( $name, $type, $fields ) = @{ $key }{ qw( name type fields ) };
            if ( $type eq 'primary_key' ) {
                $create .= " PRIMARY KEY (@{$fields})"
            } 
            else {
                local $" = ", ";
                $create .= " KEY $name (@{$fields})"
            }
        }

        #
        # Footer
        #
        $create .= "\n);\n\n";
    }

    return $create;
}

# -------------------------------------------------------------------
sub mk_name {
    my ($basename, $type, $scope, $critical) = @_;
    my $basename_orig = $basename;
    my $max_name      = $max_id_length - (length($type) + 1);
    $basename         = substr( $basename, 0, $max_name ) 
                        if length( $basename ) > $max_name;
    my $name          = $type ? "${type}_$basename" : $basename;

    if ( $basename ne $basename_orig and $critical ) {
        my $show_type = $type ? "+'$type'" : "";
        warn "Truncating '$basename_orig'$show_type to $max_id_length ",
            "character limit to make '$name'\n" if $WARN;
        $truncated{ $basename_orig } = $name;
    }

    $scope ||= \%global_names;
    if ( my $prev = $scope->{ $name } ) {
        my $name_orig = $name;
        $name        .= sprintf( "%02d", ++$prev );
        substr($name, $max_id_length - 3) = "00" 
            if length( $name ) > $max_id_length;

        warn "The name '$name_orig' has been changed to ",
             "'$name' to make it unique.\n" if $WARN;

        $scope->{ $name_orig }++;
    }

    $scope->{ $name }++;
    return $name;
}

# -------------------------------------------------------------------
sub unreserve {
    my ( $name, $schema_obj_name ) = @_;
    my ( $suffix ) = ( $name =~ s/(\W.*)$// ) ? $1 : '';

    # also trap fields that don't begin with a letter
    return $_[0] if !$reserved{ uc $name } && $name =~ /^[a-z]/i; 

    if ( $schema_obj_name ) {
        ++$unreserve{"$schema_obj_name.$name"};
    }
    else {
        ++$unreserve{"$name (table name)"};
    }

    my $unreserve = sprintf '%s_', $name;
    return $unreserve.$suffix;
}

1;

# -------------------------------------------------------------------
# Life is full of misery, loneliness, and suffering --
# and it's all over much too soon.
# Woody Allen
# -------------------------------------------------------------------

=pod

=head1 AUTHOR

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

=cut
Commit	Line	Data
f8f0253c	1	package SQL::Translator::Producer::PostgreSQL;
	2
	3	# -------------------------------------------------------------------
96844cae	4	# $Id: PostgreSQL.pm,v 1.3 2002-11-26 03:59:58 kycl4rk Exp $
f8f0253c	5	# -------------------------------------------------------------------
d529894e	6	# Copyright (C) 2002 Ken Y. Clark <kclark@cpan.org>,
f8f0253c	7	# darren chamberlain <darren@cpan.org>
	8	#
	9	# This program is free software; you can redistribute it and/or
	10	# modify it under the terms of the GNU General Public License as
	11	# published by the Free Software Foundation; version 2.
	12	#
	13	# This program is distributed in the hope that it will be useful, but
	14	# WITHOUT ANY WARRANTY; without even the implied warranty of
	15	# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
	16	# General Public License for more details.
	17	#
	18	# You should have received a copy of the GNU General Public License
	19	# along with this program; if not, write to the Free Software
	20	# Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA
	21	# 02111-1307 USA
	22	# -------------------------------------------------------------------
	23
96844cae	24	=head1 NAME
	25
	26	SQL::Translator::Producer::PostgreSQL - PostgreSQL producer for SQL::Translator
	27
	28	=cut
	29
f8f0253c	30	use strict;
96844cae	31	use vars qw[ $DEBUG $WARN $VERSION ];
96844cae	32	$VERSION = sprintf "%d.%02d", q$Revision: 1.3 $ =~ /(\d+)\.(\d+)/;
f8f0253c	33	$DEBUG = 1 unless defined $DEBUG;
	34
	35	use Data::Dumper;
	36
d529894e	37	my %translate = (
	38	#
	39	# MySQL types
	40	#
	41	bigint => 'bigint',
	42	double => 'double precision',
	43	decimal => 'decimal',
	44	float => 'double precision',
	45	int => 'integer',
	46	mediumint => 'integer',
	47	smallint => 'smallint',
	48	tinyint => 'smallint',
	49	char => 'char',
	50	varchar => 'varchar',
	51	longtext => 'text',
	52	mediumtext => 'text',
	53	text => 'text',
	54	tinytext => 'text',
	55	tinyblob => 'bytea',
	56	blob => 'bytea',
	57	mediumblob => 'bytea',
	58	longblob => 'bytea',
	59	enum => 'varchar',
	60	set => 'varchar',
	61	date => 'date',
	62	datetime => 'timestamp',
	63	time => 'date',
	64	timestamp => 'timestamp',
	65	year => 'date',
	66
	67	#
	68	# Oracle types
	69	#
96844cae	70	number => 'integer',
	71	char => 'char',
	72	varchar2 => 'varchar',
	73	long => 'text',
	74	CLOB => 'bytea',
	75	date => 'date',
	76
	77	#
	78	# Sybase types
	79	#
	80	int => 'integer',
	81	money => 'money',
	82	varchar => 'varchar',
	83	datetime => 'timestamp',
	84	text => 'text',
	85	real => 'double precision',
	86	comment => 'text',
	87	bit => 'bit',
	88	tinyint => 'smallint',
	89	float => 'double precision',
d529894e	90	);
d529894e	91
96844cae	92	my %reserved = map { $_, 1 } qw[
	93	ALL ANALYSE ANALYZE AND ANY AS ASC
	94	BETWEEN BINARY BOTH
	95	CASE CAST CHECK COLLATE COLUMN CONSTRAINT CROSS
	96	CURRENT_DATE CURRENT_TIME CURRENT_TIMESTAMP CURRENT_USER
	97	DEFAULT DEFERRABLE DESC DISTINCT DO
	98	ELSE END EXCEPT
	99	FALSE FOR FOREIGN FREEZE FROM FULL
	100	GROUP HAVING
	101	ILIKE IN INITIALLY INNER INTERSECT INTO IS ISNULL
	102	JOIN LEADING LEFT LIKE LIMIT
	103	NATURAL NEW NOT NOTNULL NULL
	104	OFF OFFSET OLD ON ONLY OR ORDER OUTER OVERLAPS
	105	PRIMARY PUBLIC REFERENCES RIGHT
	106	SELECT SESSION_USER SOME TABLE THEN TO TRAILING TRUE
	107	UNION UNIQUE USER USING VERBOSE WHEN WHERE
	108	];
d529894e	109
96844cae	110	my $max_id_length = 30;
	111	my %used_identifiers = ();
	112	my %global_names;
	113	my %unreserve;
	114	my %truncated;
	115
	116	=pod
	117
	118	=head1 PostgreSQL Create Table Syntax
	119
	120	CREATE [ [ LOCAL ] { TEMPORARY \| TEMP } ] TABLE table_name (
	121	{ column_name data_type [ DEFAULT default_expr ] [ column_constraint [, ... ] ]
	122	\| table_constraint } [, ... ]
	123	)
	124	[ INHERITS ( parent_table [, ... ] ) ]
	125	[ WITH OIDS \| WITHOUT OIDS ]
	126
	127	where column_constraint is:
	128
	129	[ CONSTRAINT constraint_name ]
	130	{ NOT NULL \| NULL \| UNIQUE \| PRIMARY KEY \|
	131	CHECK (expression) \|
	132	REFERENCES reftable [ ( refcolumn ) ] [ MATCH FULL \| MATCH PARTIAL ]
	133	[ ON DELETE action ] [ ON UPDATE action ] }
	134	[ DEFERRABLE \| NOT DEFERRABLE ] [ INITIALLY DEFERRED \| INITIALLY IMMEDIATE ]
	135
	136	and table_constraint is:
	137
	138	[ CONSTRAINT constraint_name ]
	139	{ UNIQUE ( column_name [, ... ] ) \|
	140	PRIMARY KEY ( column_name [, ... ] ) \|
	141	CHECK ( expression ) \|
	142	FOREIGN KEY ( column_name [, ... ] ) REFERENCES reftable [ ( refcolumn [, ... ] ) ]
	143	[ MATCH FULL \| MATCH PARTIAL ] [ ON DELETE action ] [ ON UPDATE action ] }
	144	[ DEFERRABLE \| NOT DEFERRABLE ] [ INITIALLY DEFERRED \| INITIALLY IMMEDIATE ]
	145
	146	=cut
f8f0253c	147
96844cae	148	# -------------------------------------------------------------------
f8f0253c	149	sub produce {
f8f0253c	150	my ( $translator, $data ) = @_;
96844cae	151	$DEBUG = $translator->debug;
	152	$WARN = $translator->show_warnings;
	153	my $no_comments = $translator->no_comments;
	154	my $add_drop_table = $translator->add_drop_table;
	155
	156	my $create;
	157	unless ( $no_comments ) {
	158	$create .= sprintf
	159	"--\n-- Created by %s\n-- Created on %s\n--\n\n",
	160	__PACKAGE__, scalar localtime;
	161	}
	162
	163	for my $table (
	164	map { $_->[1] }
	165	sort { $a->[0] <=> $b->[0] }
	166	map { [ $_->{'order'}, $_ ] }
	167	values %$data
	168	) {
	169	my $table_name = $table->{'table_name'};
	170	my @fields =
	171	map { $_->[1] }
	172	sort { $a->[0] <=> $b->[0] }
	173	map { [ $_->{'order'}, $_ ] }
	174	values %{ $table->{'fields'} };
	175
	176	$create .= "--\n-- Table: $table_name\n--\n" unless $no_comments;
	177	$create = "DROP TABLE $table_name;\n" if $add_drop_table;
	178	$create .= "CREATE TABLE $table_name (\n";
f8f0253c	179
	180	#
	181	# Fields
	182	#
96844cae	183	my %field_name_scope;
f8f0253c	184	my @field_statements;
d529894e	185	for my $field ( @fields ) {
96844cae	186	my @fdata = ("", $field);
	187
	188	my $field_name = mk_name(
	189	$field->{'name'}, '', \%field_name_scope, 1
	190	);
	191	my $field_name_ur = unreserve( $field_name, $table_name );
	192	my $field_str = $field_name_ur;
f8f0253c	193
	194	# data type and size
	195	push @fdata, sprintf "%s%s",
96844cae	196	$field->{'data_type'},
	197	( defined $field->{'size'} )
	198	? "($field->{'size'})" : '';
f8f0253c	199
f8f0253c	200	# Null?
96844cae	201	push @fdata, "NOT NULL" unless $field->{'null'};
f8f0253c	202
f8f0253c	203	# Default? XXX Need better quoting!
96844cae	204	my $default = $field->{'default'};
d529894e	205	if ( defined $default ) {
f8f0253c	206	push @fdata, "DEFAULT '$default'";
	207	# if (int $default eq "$default") {
	208	# push @fdata, "DEFAULT $default";
	209	# } else {
	210	# push @fdata, "DEFAULT '$default'";
	211	# }
	212	}
	213
	214	# auto_increment?
96844cae	215	push @fdata, "auto_increment" if $field->{'is_auto_inc'};
f8f0253c	216
f8f0253c	217	# primary key?
96844cae	218	push @fdata, "PRIMARY KEY" if $field->{'is_primary_key'};
f8f0253c	219
	220	push @field_statements, join( " ", @fdata );
	221
	222	}
	223	$create .= join( ",\n", @field_statements );
	224
	225	#
	226	# Other keys
	227	#
96844cae	228	my @indices = @{ $table->{'indices'} \|\| [] };
f8f0253c	229	for ( my $i = 0; $i <= $#indices; $i++ ) {
	230	$create .= ",\n";
	231	my $key = $indices[$i];
	232	my ( $name, $type, $fields ) = @{ $key }{ qw( name type fields ) };
	233	if ( $type eq 'primary_key' ) {
	234	$create .= " PRIMARY KEY (@{$fields})"
	235	}
	236	else {
	237	local $" = ", ";
	238	$create .= " KEY $name (@{$fields})"
	239	}
	240	}
	241
	242	#
	243	# Footer
	244	#
	245	$create .= "\n);\n\n";
	246	}
	247
	248	return $create;
	249	}
	250
96844cae	251	# -------------------------------------------------------------------
	252	sub mk_name {
	253	my ($basename, $type, $scope, $critical) = @_;
	254	my $basename_orig = $basename;
	255	my $max_name = $max_id_length - (length($type) + 1);
	256	$basename = substr( $basename, 0, $max_name )
	257	if length( $basename ) > $max_name;
	258	my $name = $type ? "${type}_$basename" : $basename;
	259
	260	if ( $basename ne $basename_orig and $critical ) {
	261	my $show_type = $type ? "+'$type'" : "";
	262	warn "Truncating '$basename_orig'$show_type to $max_id_length ",
	263	"character limit to make '$name'\n" if $WARN;
	264	$truncated{ $basename_orig } = $name;
	265	}
	266
	267	$scope \|\|= \%global_names;
	268	if ( my $prev = $scope->{ $name } ) {
	269	my $name_orig = $name;
	270	$name .= sprintf( "%02d", ++$prev );
	271	substr($name, $max_id_length - 3) = "00"
	272	if length( $name ) > $max_id_length;
	273
	274	warn "The name '$name_orig' has been changed to ",
	275	"'$name' to make it unique.\n" if $WARN;
	276
	277	$scope->{ $name_orig }++;
f8f0253c	278	}
96844cae	279
	280	$scope->{ $name }++;
	281	return $name;
	282	}
	283
	284	# -------------------------------------------------------------------
	285	sub unreserve {
	286	my ( $name, $schema_obj_name ) = @_;
	287	my ( $suffix ) = ( $name =~ s/(\W.*)$// ) ? $1 : '';
	288
	289	# also trap fields that don't begin with a letter
	290	return $_[0] if !$reserved{ uc $name } && $name =~ /^[a-z]/i;
	291
	292	if ( $schema_obj_name ) {
	293	++$unreserve{"$schema_obj_name.$name"};
	294	}
	295	else {
	296	++$unreserve{"$name (table name)"};
	297	}
	298
	299	my $unreserve = sprintf '%s_', $name;
	300	return $unreserve.$suffix;
f8f0253c	301	}
	302
	303	1;
f8f0253c	304
96844cae	305	# -------------------------------------------------------------------
	306	# Life is full of misery, loneliness, and suffering --
	307	# and it's all over much too soon.
	308	# Woody Allen
	309	# -------------------------------------------------------------------
f8f0253c	310
96844cae	311	=pod
f8f0253c	312
	313	=head1 AUTHOR
	314
	315	Ken Y. Clark E<lt>kclark@cpan.orgE<gt>
	316
	317	=cut