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

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

# -------------------------------------------------------------------
# $Id: PostgreSQL.pm,v 1.25 2006-08-04 21:38:20 schiffbruechige Exp $
# -------------------------------------------------------------------
# Copyright (C) 2002-4 SQLFairy Authors
#
# 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

=head1 SYNOPSIS

  my $t = SQL::Translator->new( parser => '...', producer => 'PostgreSQL' );
  $t->translate;

=head1 DESCRIPTION

Creates a DDL suitable for PostgreSQL.  Very heavily based on the Oracle
producer.

=cut

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

use SQL::Translator::Schema::Constants;
use SQL::Translator::Utils qw(header_comment);
use Data::Dumper;

my %translate;
my $max_id_length;

BEGIN {

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

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

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

 $max_id_length = 62;
}
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    = 62;
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 ]

=head1 Create Index Syntax

  CREATE [ UNIQUE ] INDEX index_name ON table
      [ USING acc_method ] ( column [ ops_name ] [, ...] )
      [ WHERE predicate ]
  CREATE [ UNIQUE ] INDEX index_name ON table
      [ USING acc_method ] ( func_name( column [, ... ]) [ ops_name ] )
      [ WHERE predicate ]

=cut

# -------------------------------------------------------------------
sub produce {
    my $translator     = shift;
    $DEBUG             = $translator->debug;
    $WARN              = $translator->show_warnings;
    my $no_comments    = $translator->no_comments;
    my $add_drop_table = $translator->add_drop_table;
    my $schema         = $translator->schema;

    my $qt = '';
    $qt = '"' if ($translator->quote_table_names);
    my $qf = '';
    $qf = '"' if ($translator->quote_field_names);
    
    my $output;
    $output .= header_comment unless ($no_comments);
#    my %used_index_names;

    my (@table_defs, @fks);
    for my $table ( $schema->get_tables ) {

        my ($table_def, $fks) = create_table($table, 
                                             { quote_table_names => $qt,
                                               quote_field_names => $qf,
                                               no_comments => $no_comments,
                                               add_drop_table => $add_drop_table,});
        push @table_defs, $table_def;
        push @fks, @$fks;

    }

    $output = join("\n\n", @table_defs);
    if ( @fks ) {
        $output .= "--\n-- Foreign Key Definitions\n--\n\n" unless $no_comments;
        $output .= join( "\n\n", @fks );
    }

    if ( $WARN ) {
        if ( %truncated ) {
            warn "Truncated " . keys( %truncated ) . " names:\n";
            warn "\t" . join( "\n\t", sort keys %truncated ) . "\n";
        }

        if ( %unreserve ) {
            warn "Encounted " . keys( %unreserve ) .
                " unsafe names in schema (reserved or invalid):\n";
            warn "\t" . join( "\n\t", sort keys %unreserve ) . "\n";
        }
    }

    return $output;
}

# -------------------------------------------------------------------
sub mk_name {
    my $basename      = shift || ''; 
    my $type          = shift || ''; 
    my $scope         = shift || ''; 
    my $critical      = shift || '';
    my $basename_orig = $basename;
#    my $max_id_length = 62;
    my $max_name      = $type 
                        ? $max_id_length - (length($type) + 1) 
                        : $max_id_length;
    $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            = shift || '';
    my $schema_obj_name = shift || '';

    my ( $suffix ) = ( $name =~ s/(\W.*)$// ) ? $1 : '';

    # also trap fields that don't begin with a letter
    return $name 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;
}

# -------------------------------------------------------------------
sub next_unused_name {
    my $name       = shift || '';
    my $used_names = shift || '';

    my %used_names = %$used_names;

    if ( !defined($used_names{$name}) ) {
        $used_names{$name} = $name;
        return $name;
    }
    
    my $i = 2;
    while ( defined($used_names{$name . $i}) ) {
        ++$i;
    }
    $name .= $i;
    $used_names{$name} = $name;
    return $name;
}

sub create_table 
{
    my ($table, $options) = @_;

    my $qt = $options->{quote_table_names} || '';
    my $qf = $options->{quote_field_names} || '';
    my $no_comments = $options->{no_comments} || 0;
    my $add_drop_table = $options->{add_drop_table} || 0;

    my $table_name    = $table->name or next;
    $table_name       = mk_name( $table_name, '', undef, 1 );
    my $table_name_ur = $qt ? $table_name : unreserve($table_name);
    $table->name($table_name_ur);

# print STDERR "$table_name table_name\n";
    my ( @comments, @field_defs, @sequence_defs, @constraint_defs, @fks );

    push @comments, "--\n-- Table: $table_name_ur\n--" unless $no_comments;

    if ( $table->comments and !$no_comments ){
        my $c = "-- Comments: \n-- ";
        $c .= join "\n-- ",  $table->comments;
        $c .= "\n--";
        push @comments, $c;
    }

    #
    # Fields
    #
    my %field_name_scope;
    for my $field ( $table->get_fields ) {
        push @field_defs, create_field($field, { quote_table_names => $qt,
                                                 quote_field_names => $qf,
                                                 table_name => $table_name_ur,
                                                 constraint_defs => \@constraint_defs,});
    }

    #
    # Index Declarations
    #
    my @index_defs = ();
 #   my $idx_name_default;
    for my $index ( $table->get_indices ) {
        my ($idef, $constraints) = create_index($index,
                                              { 
                                                  quote_field_names => $qf,
                                                  quote_table_names => $qt,
                                                  table_name => $table_name,
                                              });
        push @index_defs, $idef;
        push @constraint_defs, @$constraints;
    }

    #
    # Table constraints
    #
    my $c_name_default;
    for my $c ( $table->get_constraints ) {
        my ($cdefs, $fks) = create_constraint($c, 
                                              { 
                                                  quote_field_names => $qf,
                                                  quote_table_names => $qt,
                                                  table_name => $table_name,
                                              });
        push @constraint_defs, @$cdefs;
        push @fks, @$fks;
    }

    my $create_statement;
    $create_statement = join("\n", @comments);
    $create_statement .= qq[DROP TABLE $qt$table_name_ur$qt;\n] 
        if $add_drop_table;
    $create_statement .= qq[CREATE TABLE $qt$table_name_ur$qt (\n].
                            join( ",\n", map { "  $_" } @field_defs, @constraint_defs ).
                            "\n);"
                            ;

    $create_statement .= "\n" . join(";\n", @index_defs) . "\n";
    
    return $create_statement, \@fks;
}

{ 

    my %field_name_scope;

    sub create_field
    {
        my ($field, $options) = @_;

        my $qt = $options->{quote_table_names} || '';
        my $qf = $options->{quote_field_names} || '';
        my $table_name = $field->table->name;
        my $constraint_defs = $options->{constraint_defs} || [];

        $field_name_scope{$table_name} ||= {};
        my $field_name    = mk_name(
                                    $field->name, '', $field_name_scope{$table_name}, 1 
                                    );
        my $field_name_ur = $qf ? $field_name : unreserve($field_name, $table_name );
        $field->name($field_name_ur);
        my $field_comments = $field->comments 
            ? "-- " . $field->comments . "\n  " 
            : '';

        my $field_def     = $field_comments.qq[$qf$field_name_ur$qf];

        #
        # Datatype
        #
        my @size      = $field->size;
        my $data_type = lc $field->data_type;
        my %extra     = $field->extra;
        my $list      = $extra{'list'} || [];
        # todo deal with embedded quotes
        my $commalist = join( ', ', map { qq['$_'] } @$list );
        my $seq_name;

        $field_def .= ' '. convert_datatype($field);

        #
        # Default value -- disallow for timestamps
        #
        my $default = $data_type =~ /(timestamp|date)/i
            ? undef : $field->default_value;
        if ( defined $default ) {
            $field_def .= sprintf( ' DEFAULT %s',
                                   ( $field->is_auto_increment && $seq_name )
                                   ? qq[nextval('"$seq_name"'::text)] :
                                   ( $default =~ m/null/i ) ? 'NULL' : "'$default'"
                                   );
        }

        #
        # Not null constraint
        #
        $field_def .= ' NOT NULL' unless $field->is_nullable;

        return $field_def;
    }
}

{
    my %used_index_names;

    sub create_index
    {
        my ($index, $options) = @_;

        my $qt = $options->{quote_table_names} ||'';
        my $qf = $options->{quote_field_names} ||'';
        my $table_name = $index->table->name;
#        my $table_name_ur = $qt ? unreserve($table_name) : $table_name;

        my ($index_def, @constraint_defs);

        $used_index_names{$table_name} ||= {};
        my $name = $index->name || '';
        if ( $name ) {
            $name = next_unused_name($name, $used_index_names{$table_name});
            $used_index_names{$name} = $name;
        }

        my $type = $index->type || NORMAL;
        my @fields     = 
            map { $_ =~ s/\(.+\)//; $_ }
        map { $qt ? $_ : unreserve($_, $table_name ) }
        $index->fields;
        next unless @fields;

        my $def_start = qq[Constraint "$name" ];
        if ( $type eq PRIMARY_KEY ) {
            push @constraint_defs, "${def_start}PRIMARY KEY ".
                '(' .$qf . join( $qf. ', '.$qf, @fields ) . $qf . ')';
        }
        elsif ( $type eq UNIQUE ) {
            push @constraint_defs, "${def_start}UNIQUE " .
                '(' . $qf . join( $qf. ', '.$qf, @fields ) . $qf.')';
        }
        elsif ( $type eq NORMAL ) {
            $index_def = 
                "CREATE INDEX ${qf}${name}${qf} on ${qt}${table_name}${qt} (".
                join( ', ', map { qq[$qf$_$qf] } @fields ).  
                ');'
                ; 
        }
        else {
            warn "Unknown index type ($type) on table $table_name.\n"
                if $WARN;
        }

        return $index_def, \@constraint_defs;
    }

    sub create_constraint
    {
        my ($c, $options) = @_;

        my $qf = $options->{quote_field_names} ||'';
        my $qt = $options->{quote_table_names} ||'';
        my $table_name = $c->table->name;
        my (@constraint_defs, @fks);

        my $name = $c->name || '';
        if ( $name ) {
            $name = next_unused_name($name, \%used_index_names);
            $used_index_names{$name} = $name;
        }

        my @fields     = 
            map { $_ =~ s/\(.+\)//; $_ }
        map { $qt ? $_ : unreserve( $_, $table_name )}
        $c->fields;

        my @rfields     = 
            map { $_ =~ s/\(.+\)//; $_ }
        map { $qt ? $_ : unreserve( $_, $table_name )}
        $c->reference_fields;

        next if !@fields && $c->type ne CHECK_C;
        my $def_start = $name ? qq[Constraint "$name" ] : '';
        if ( $c->type eq PRIMARY_KEY ) {
            push @constraint_defs, "${def_start}PRIMARY KEY ".
                '('.$qf . join( $qf.', '.$qf, @fields ) . $qf.')';
        }
        elsif ( $c->type eq UNIQUE ) {
            $name = next_unused_name($name, \%used_index_names);
            $used_index_names{$name} = $name;
            push @constraint_defs, "${def_start}UNIQUE " .
                '('.$qf . join( $qf.', '.$qf, @fields ) . $qf.')';
        }
        elsif ( $c->type eq CHECK_C ) {
            my $expression = $c->expression;
            push @constraint_defs, "${def_start}CHECK ($expression)";
        }
        elsif ( $c->type eq FOREIGN_KEY ) {
            my $def .= "ALTER TABLE ${qt}${table_name}${qt} ADD FOREIGN KEY (" . 
                join( ', ', map { qq[$qf$_$qf] } @fields ) . ')' .
                "\n  REFERENCES " . $qt . $c->reference_table . $qt;

            if ( @rfields ) {
                $def .= ' ('.$qf . join( $qf.', '.$qf, @rfields ) . $qf.')';
            }

            if ( $c->match_type ) {
                $def .= ' MATCH ' . 
                    ( $c->match_type =~ /full/i ) ? 'FULL' : 'PARTIAL';
            }

            if ( $c->on_delete ) {
                $def .= ' ON DELETE '.join( ' ', $c->on_delete );
            }

            if ( $c->on_update ) {
                $def .= ' ON UPDATE '.join( ' ', $c->on_update );
            }

            push @fks, "$def;";
        }

        return \@constraint_defs, \@fks;
    }
}

sub convert_datatype
{
    my ($field) = @_;

    my @size      = $field->size;
    my $data_type = lc $field->data_type;

    if ( $data_type eq 'enum' ) {
#        my $len = 0;
#        $len = ($len < length($_)) ? length($_) : $len for (@$list);
#        my $chk_name = mk_name( $table_name.'_'.$field_name, 'chk' );
#        push @$constraint_defs, 
#        qq[Constraint "$chk_name" CHECK ($qf$field_name$qf ].
#           qq[IN ($commalist))];
        $data_type = 'character varying';
    }
    elsif ( $data_type eq 'set' ) {
        $data_type = 'character varying';
    }
    elsif ( $field->is_auto_increment ) {
        if ( defined $size[0] && $size[0] > 11 ) {
            $data_type = 'bigserial';
        }
        else {
            $data_type = 'serial';
        }
        undef @size;
    }
    else {
        $data_type  = defined $translate{ $data_type } ?
            $translate{ $data_type } :
            $data_type;
    }

    if ( $data_type =~ /timestamp/i ) {
        if ( defined $size[0] && $size[0] > 6 ) {
            $size[0] = 6;
        }
    }

    if ( $data_type eq 'integer' ) {
        if ( defined $size[0] && $size[0] > 0) {
            if ( $size[0] > 10 ) {
                $data_type = 'bigint';
            }
            elsif ( $size[0] < 5 ) {
                $data_type = 'smallint';
            }
            else {
                $data_type = 'integer';
            }
        }
        else {
            $data_type = 'integer';
        }
    }

    #
    # PG doesn't need a size for integers or text
    #
    undef @size if $data_type =~ m/(integer|smallint|bigint|text)/;
    
    if ( defined $size[0] && $size[0] > 0 ) {
        $data_type .= '(' . join( ',', @size ) . ')';
    }
    elsif (defined $size[0] && $data_type eq 'timestamp' ) {
        $data_type .= '(' . join( ',', @size ) . ')';
    }


    return $data_type;
}


sub alter_field
{
    my ($from_field, $to_field) = @_;

    die "Can't alter field in another table" 
        if($from_field->table->name ne $to_field->table->name);

    my @out;
    push @out, sprintf('ALTER TABLE %s ALTER COLUMN %s SET NOT NULL;',
                       $to_field->table->name,
                       $to_field->name) if(!$to_field->is_nullable and
                                           $from_field->is_nullable);

    my $from_dt = convert_datatype($from_field);
    my $to_dt   = convert_datatype($to_field);
    push @out, sprintf('ALTER TABLE %s ALTER COLUMN %s TYPE %s;',
                       $to_field->table->name,
                       $to_field->name,
                       $to_dt) if($to_dt ne $from_dt);

    push @out, sprintf('ALTER TABLE %s RENAME COLUMN %s TO %s;',
                       $to_field->table->name,
                       $from_field->name,
                       $to_field->name) if($from_field->name ne $to_field->name);

    push @out, sprintf('ALTER TABLE %s ALTER COLUMN %s SET DEFAULT %s;',
                       $to_field->table->name,
                       $to_field->name,
                       $to_field->default_value) 
        if(defined $to_field->default_value && 
           $from_field->default_value ne $to_field->default_value);

    return wantarray ? @out : join("\n", @out);
    
}

sub add_field
{
    my ($new_field) = @_;

    my $out = sprintf('ALTER TABLE %s ADD COLUMN %s;',
                      $new_field->table->name,
                      create_field($new_field));
    return $out;

}

sub drop_field
{
    my ($old_field) = @_;

    my $out = sprintf('ALTER TABLE %s DROP COLUMN %s;',
                      $old_field->table->name,
                      $old_field->name);

    return $out;    
}

1;

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

=pod

=head1 SEE ALSO

SQL::Translator, SQL::Translator::Producer::Oracle.

=head1 AUTHOR

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

=cut
Commit	Line	Data
f8f0253c	1	package SQL::Translator::Producer::PostgreSQL;
	2
	3	# -------------------------------------------------------------------
08d91aad	4	# $Id: PostgreSQL.pm,v 1.25 2006-08-04 21:38:20 schiffbruechige Exp $
f8f0253c	5	# -------------------------------------------------------------------
977651a5	6	# Copyright (C) 2002-4 SQLFairy Authors
f8f0253c	7	#
	8	# This program is free software; you can redistribute it and/or
	9	# modify it under the terms of the GNU General Public License as
	10	# published by the Free Software Foundation; version 2.
	11	#
	12	# This program is distributed in the hope that it will be useful, but
	13	# WITHOUT ANY WARRANTY; without even the implied warranty of
	14	# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
	15	# General Public License for more details.
	16	#
	17	# You should have received a copy of the GNU General Public License
	18	# along with this program; if not, write to the Free Software
	19	# Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA
	20	# 02111-1307 USA
	21	# -------------------------------------------------------------------
	22
96844cae	23	=head1 NAME
	24
	25	SQL::Translator::Producer::PostgreSQL - PostgreSQL producer for SQL::Translator
	26
20770e44	27	=head1 SYNOPSIS
	28
	29	my $t = SQL::Translator->new( parser => '...', producer => 'PostgreSQL' );
	30	$t->translate;
	31
	32	=head1 DESCRIPTION
	33
	34	Creates a DDL suitable for PostgreSQL. Very heavily based on the Oracle
	35	producer.
	36
96844cae	37	=cut
96844cae	38
f8f0253c	39	use strict;
bfb5a568	40	use warnings;
96844cae	41	use vars qw[ $DEBUG $WARN $VERSION ];
08d91aad	42	$VERSION = sprintf "%d.%02d", q$Revision: 1.25 $ =~ /(\d+)\.(\d+)/;
f8f0253c	43	$DEBUG = 1 unless defined $DEBUG;
f8f0253c	44
0c43e0a1	45	use SQL::Translator::Schema::Constants;
5ee19df8	46	use SQL::Translator::Utils qw(header_comment);
f8f0253c	47	use Data::Dumper;
f8f0253c	48
bfb5a568	49	my %translate;
	50	my $max_id_length;
	51
	52	BEGIN {
	53
	54	%translate = (
d529894e	55	#
	56	# MySQL types
	57	#
	58	bigint => 'bigint',
4328d7bd	59	double => 'numeric',
	60	decimal => 'numeric',
	61	float => 'numeric',
d529894e	62	int => 'integer',
	63	mediumint => 'integer',
	64	smallint => 'smallint',
	65	tinyint => 'smallint',
c8c17a58	66	char => 'character',
da8e499e	67	varchar => 'character varying',
d529894e	68	longtext => 'text',
	69	mediumtext => 'text',
	70	text => 'text',
	71	tinytext => 'text',
	72	tinyblob => 'bytea',
	73	blob => 'bytea',
	74	mediumblob => 'bytea',
	75	longblob => 'bytea',
da8e499e	76	enum => 'character varying',
da8e499e	77	set => 'character varying',
d529894e	78	date => 'date',
	79	datetime => 'timestamp',
	80	time => 'date',
	81	timestamp => 'timestamp',
	82	year => 'date',
	83
	84	#
	85	# Oracle types
	86	#
96844cae	87	number => 'integer',
c8c17a58	88	char => 'character',
da8e499e	89	varchar2 => 'character varying',
96844cae	90	long => 'text',
	91	CLOB => 'bytea',
	92	date => 'date',
	93
	94	#
	95	# Sybase types
	96	#
	97	int => 'integer',
	98	money => 'money',
da8e499e	99	varchar => 'character varying',
96844cae	100	datetime => 'timestamp',
96844cae	101	text => 'text',
4328d7bd	102	real => 'numeric',
96844cae	103	comment => 'text',
	104	bit => 'bit',
	105	tinyint => 'smallint',
4328d7bd	106	float => 'numeric',
d529894e	107	);
d529894e	108
bfb5a568	109	$max_id_length = 62;
bfb5a568	110	}
96844cae	111	my %reserved = map { $_, 1 } qw[
	112	ALL ANALYSE ANALYZE AND ANY AS ASC
	113	BETWEEN BINARY BOTH
	114	CASE CAST CHECK COLLATE COLUMN CONSTRAINT CROSS
	115	CURRENT_DATE CURRENT_TIME CURRENT_TIMESTAMP CURRENT_USER
	116	DEFAULT DEFERRABLE DESC DISTINCT DO
	117	ELSE END EXCEPT
	118	FALSE FOR FOREIGN FREEZE FROM FULL
	119	GROUP HAVING
	120	ILIKE IN INITIALLY INNER INTERSECT INTO IS ISNULL
	121	JOIN LEADING LEFT LIKE LIMIT
	122	NATURAL NEW NOT NOTNULL NULL
	123	OFF OFFSET OLD ON ONLY OR ORDER OUTER OVERLAPS
	124	PRIMARY PUBLIC REFERENCES RIGHT
	125	SELECT SESSION_USER SOME TABLE THEN TO TRAILING TRUE
	126	UNION UNIQUE USER USING VERBOSE WHEN WHERE
	127	];
d529894e	128
bfb5a568	129	# my $max_id_length = 62;
96844cae	130	my %used_identifiers = ();
	131	my %global_names;
	132	my %unreserve;
	133	my %truncated;
	134
	135	=pod
	136
	137	=head1 PostgreSQL Create Table Syntax
	138
	139	CREATE [ [ LOCAL ] { TEMPORARY \| TEMP } ] TABLE table_name (
	140	{ column_name data_type [ DEFAULT default_expr ] [ column_constraint [, ... ] ]
	141	\| table_constraint } [, ... ]
	142	)
	143	[ INHERITS ( parent_table [, ... ] ) ]
	144	[ WITH OIDS \| WITHOUT OIDS ]
	145
	146	where column_constraint is:
	147
	148	[ CONSTRAINT constraint_name ]
	149	{ NOT NULL \| NULL \| UNIQUE \| PRIMARY KEY \|
	150	CHECK (expression) \|
	151	REFERENCES reftable [ ( refcolumn ) ] [ MATCH FULL \| MATCH PARTIAL ]
	152	[ ON DELETE action ] [ ON UPDATE action ] }
	153	[ DEFERRABLE \| NOT DEFERRABLE ] [ INITIALLY DEFERRED \| INITIALLY IMMEDIATE ]
	154
	155	and table_constraint is:
	156
	157	[ CONSTRAINT constraint_name ]
	158	{ UNIQUE ( column_name [, ... ] ) \|
	159	PRIMARY KEY ( column_name [, ... ] ) \|
	160	CHECK ( expression ) \|
	161	FOREIGN KEY ( column_name [, ... ] ) REFERENCES reftable [ ( refcolumn [, ... ] ) ]
	162	[ MATCH FULL \| MATCH PARTIAL ] [ ON DELETE action ] [ ON UPDATE action ] }
	163	[ DEFERRABLE \| NOT DEFERRABLE ] [ INITIALLY DEFERRED \| INITIALLY IMMEDIATE ]
	164
da8e499e	165	=head1 Create Index Syntax
	166
	167	CREATE [ UNIQUE ] INDEX index_name ON table
	168	[ USING acc_method ] ( column [ ops_name ] [, ...] )
	169	[ WHERE predicate ]
	170	CREATE [ UNIQUE ] INDEX index_name ON table
	171	[ USING acc_method ] ( func_name( column [, ... ]) [ ops_name ] )
	172	[ WHERE predicate ]
	173
96844cae	174	=cut
f8f0253c	175
96844cae	176	# -------------------------------------------------------------------
f8f0253c	177	sub produce {
a1d94525	178	my $translator = shift;
	179	$DEBUG = $translator->debug;
	180	$WARN = $translator->show_warnings;
	181	my $no_comments = $translator->no_comments;
	182	my $add_drop_table = $translator->add_drop_table;
	183	my $schema = $translator->schema;
96844cae	184
bfb5a568	185	my $qt = '';
	186	$qt = '"' if ($translator->quote_table_names);
	187	my $qf = '';
	188	$qf = '"' if ($translator->quote_field_names);
	189
da8e499e	190	my $output;
5ee19df8	191	$output .= header_comment unless ($no_comments);
bfb5a568	192	# my %used_index_names;
96844cae	193
08d91aad	194	my (@table_defs, @fks);
0c43e0a1	195	for my $table ( $schema->get_tables ) {
08d91aad	196
	197	my ($table_def, $fks) = create_table($table,
	198	{ quote_table_names => $qt,
	199	quote_field_names => $qf,
	200	no_comments => $no_comments,
	201	add_drop_table => $add_drop_table,});
	202	push @table_defs, $table_def;
	203	push @fks, @$fks;
	204
da8e499e	205	}
da8e499e	206
bfb5a568	207	$output = join("\n\n", @table_defs);
08d91aad	208	if ( @fks ) {
	209	$output .= "--\n-- Foreign Key Definitions\n--\n\n" unless $no_comments;
	210	$output .= join( "\n\n", @fks );
	211	}
021dbce8	212
da8e499e	213	if ( $WARN ) {
	214	if ( %truncated ) {
	215	warn "Truncated " . keys( %truncated ) . " names:\n";
	216	warn "\t" . join( "\n\t", sort keys %truncated ) . "\n";
	217	}
	218
	219	if ( %unreserve ) {
	220	warn "Encounted " . keys( %unreserve ) .
	221	" unsafe names in schema (reserved or invalid):\n";
	222	warn "\t" . join( "\n\t", sort keys %unreserve ) . "\n";
	223	}
f8f0253c	224	}
f8f0253c	225
da8e499e	226	return $output;
f8f0253c	227	}
f8f0253c	228
96844cae	229	# -------------------------------------------------------------------
96844cae	230	sub mk_name {
0c43e0a1	231	my $basename = shift \|\| '';
	232	my $type = shift \|\| '';
	233	my $scope = shift \|\| '';
	234	my $critical = shift \|\| '';
96844cae	235	my $basename_orig = $basename;
bfb5a568	236	# my $max_id_length = 62;
2ad4c2c8	237	my $max_name = $type
	238	? $max_id_length - (length($type) + 1)
	239	: $max_id_length;
96844cae	240	$basename = substr( $basename, 0, $max_name )
	241	if length( $basename ) > $max_name;
	242	my $name = $type ? "${type}_$basename" : $basename;
	243
	244	if ( $basename ne $basename_orig and $critical ) {
	245	my $show_type = $type ? "+'$type'" : "";
	246	warn "Truncating '$basename_orig'$show_type to $max_id_length ",
	247	"character limit to make '$name'\n" if $WARN;
	248	$truncated{ $basename_orig } = $name;
	249	}
	250
	251	$scope \|\|= \%global_names;
	252	if ( my $prev = $scope->{ $name } ) {
	253	my $name_orig = $name;
	254	$name .= sprintf( "%02d", ++$prev );
	255	substr($name, $max_id_length - 3) = "00"
	256	if length( $name ) > $max_id_length;
	257
	258	warn "The name '$name_orig' has been changed to ",
	259	"'$name' to make it unique.\n" if $WARN;
	260
	261	$scope->{ $name_orig }++;
f8f0253c	262	}
96844cae	263
	264	$scope->{ $name }++;
	265	return $name;
	266	}
	267
	268	# -------------------------------------------------------------------
	269	sub unreserve {
0c43e0a1	270	my $name = shift \|\| '';
	271	my $schema_obj_name = shift \|\| '';
	272
96844cae	273	my ( $suffix ) = ( $name =~ s/(\W.*)$// ) ? $1 : '';
	274
	275	# also trap fields that don't begin with a letter
bfb5a568	276	return $name if (!$reserved{ uc $name }) && $name =~ /^[a-z]/i;
96844cae	277
	278	if ( $schema_obj_name ) {
	279	++$unreserve{"$schema_obj_name.$name"};
	280	}
	281	else {
	282	++$unreserve{"$name (table name)"};
	283	}
	284
	285	my $unreserve = sprintf '%s_', $name;
	286	return $unreserve.$suffix;
f8f0253c	287	}
f8f0253c	288
50840472	289	# -------------------------------------------------------------------
	290	sub next_unused_name {
	291	my $name = shift \|\| '';
	292	my $used_names = shift \|\| '';
	293
	294	my %used_names = %$used_names;
	295
	296	if ( !defined($used_names{$name}) ) {
	297	$used_names{$name} = $name;
	298	return $name;
	299	}
	300
	301	my $i = 2;
	302	while ( defined($used_names{$name . $i}) ) {
	303	++$i;
	304	}
	305	$name .= $i;
	306	$used_names{$name} = $name;
	307	return $name;
	308	}
	309
bfb5a568	310	sub create_table
	311	{
	312	my ($table, $options) = @_;
	313
	314	my $qt = $options->{quote_table_names} \|\| '';
	315	my $qf = $options->{quote_field_names} \|\| '';
	316	my $no_comments = $options->{no_comments} \|\| 0;
	317	my $add_drop_table = $options->{add_drop_table} \|\| 0;
	318
	319	my $table_name = $table->name or next;
	320	$table_name = mk_name( $table_name, '', undef, 1 );
08d91aad	321	my $table_name_ur = $qt ? $table_name : unreserve($table_name);
bfb5a568	322	$table->name($table_name_ur);
	323
	324	# print STDERR "$table_name table_name\n";
	325	my ( @comments, @field_defs, @sequence_defs, @constraint_defs, @fks );
	326
	327	push @comments, "--\n-- Table: $table_name_ur\n--" unless $no_comments;
	328
	329	if ( $table->comments and !$no_comments ){
	330	my $c = "-- Comments: \n-- ";
	331	$c .= join "\n-- ", $table->comments;
	332	$c .= "\n--";
	333	push @comments, $c;
	334	}
	335
	336	#
	337	# Fields
	338	#
	339	my %field_name_scope;
	340	for my $field ( $table->get_fields ) {
	341	push @field_defs, create_field($field, { quote_table_names => $qt,
	342	quote_field_names => $qf,
	343	table_name => $table_name_ur,
	344	constraint_defs => \@constraint_defs,});
	345	}
	346
	347	#
	348	# Index Declarations
	349	#
	350	my @index_defs = ();
	351	# my $idx_name_default;
	352	for my $index ( $table->get_indices ) {
	353	my ($idef, $constraints) = create_index($index,
	354	{
	355	quote_field_names => $qf,
	356	quote_table_names => $qt,
	357	table_name => $table_name,
	358	});
	359	push @index_defs, $idef;
	360	push @constraint_defs, @$constraints;
	361	}
	362
	363	#
	364	# Table constraints
	365	#
	366	my $c_name_default;
	367	for my $c ( $table->get_constraints ) {
	368	my ($cdefs, $fks) = create_constraint($c,
	369	{
	370	quote_field_names => $qf,
	371	quote_table_names => $qt,
	372	table_name => $table_name,
	373	});
	374	push @constraint_defs, @$cdefs;
	375	push @fks, @$fks;
	376	}
	377
	378	my $create_statement;
	379	$create_statement = join("\n", @comments);
	380	$create_statement .= qq[DROP TABLE $qt$table_name_ur$qt;\n]
	381	if $add_drop_table;
	382	$create_statement .= qq[CREATE TABLE $qt$table_name_ur$qt (\n].
	383	join( ",\n", map { " $_" } @field_defs, @constraint_defs ).
	384	"\n);"
	385	;
bfb5a568	386
	387	$create_statement .= "\n" . join(";\n", @index_defs) . "\n";
	388
08d91aad	389	return $create_statement, \@fks;
bfb5a568	390	}
	391
	392	{
	393
	394	my %field_name_scope;
	395
	396	sub create_field
	397	{
	398	my ($field, $options) = @_;
	399
	400	my $qt = $options->{quote_table_names} \|\| '';
	401	my $qf = $options->{quote_field_names} \|\| '';
	402	my $table_name = $field->table->name;
	403	my $constraint_defs = $options->{constraint_defs} \|\| [];
	404
	405	$field_name_scope{$table_name} \|\|= {};
	406	my $field_name = mk_name(
	407	$field->name, '', $field_name_scope{$table_name}, 1
	408	);
08d91aad	409	my $field_name_ur = $qf ? $field_name : unreserve($field_name, $table_name );
bfb5a568	410	$field->name($field_name_ur);
	411	my $field_comments = $field->comments
	412	? "-- " . $field->comments . "\n "
	413	: '';
	414
	415	my $field_def = $field_comments.qq[$qf$field_name_ur$qf];
	416
	417	#
	418	# Datatype
	419	#
	420	my @size = $field->size;
	421	my $data_type = lc $field->data_type;
	422	my %extra = $field->extra;
	423	my $list = $extra{'list'} \|\| [];
	424	# todo deal with embedded quotes
	425	my $commalist = join( ', ', map { qq['$_'] } @$list );
	426	my $seq_name;
	427
	428	$field_def .= ' '. convert_datatype($field);
	429
	430	#
	431	# Default value -- disallow for timestamps
	432	#
	433	my $default = $data_type =~ /(timestamp\|date)/i
	434	? undef : $field->default_value;
	435	if ( defined $default ) {
	436	$field_def .= sprintf( ' DEFAULT %s',
	437	( $field->is_auto_increment && $seq_name )
	438	? qq[nextval('"$seq_name"'::text)] :
	439	( $default =~ m/null/i ) ? 'NULL' : "'$default'"
	440	);
	441	}
	442
	443	#
	444	# Not null constraint
	445	#
	446	$field_def .= ' NOT NULL' unless $field->is_nullable;
	447
	448	return $field_def;
	449	}
	450	}
	451
	452	{
	453	my %used_index_names;
	454
	455	sub create_index
	456	{
	457	my ($index, $options) = @_;
	458
	459	my $qt = $options->{quote_table_names} \|\|'';
	460	my $qf = $options->{quote_field_names} \|\|'';
	461	my $table_name = $index->table->name;
08d91aad	462	# my $table_name_ur = $qt ? unreserve($table_name) : $table_name;
bfb5a568	463
	464	my ($index_def, @constraint_defs);
	465
	466	$used_index_names{$table_name} \|\|= {};
	467	my $name = $index->name \|\| '';
	468	if ( $name ) {
	469	$name = next_unused_name($name, $used_index_names{$table_name});
	470	$used_index_names{$name} = $name;
	471	}
	472
	473	my $type = $index->type \|\| NORMAL;
	474	my @fields =
	475	map { $_ =~ s/\(.+\)//; $_ }
08d91aad	476	map { $qt ? $_ : unreserve($_, $table_name ) }
bfb5a568	477	$index->fields;
	478	next unless @fields;
	479
	480	my $def_start = qq[Constraint "$name" ];
	481	if ( $type eq PRIMARY_KEY ) {
	482	push @constraint_defs, "${def_start}PRIMARY KEY ".
	483	'(' .$qf . join( $qf. ', '.$qf, @fields ) . $qf . ')';
	484	}
	485	elsif ( $type eq UNIQUE ) {
	486	push @constraint_defs, "${def_start}UNIQUE " .
	487	'(' . $qf . join( $qf. ', '.$qf, @fields ) . $qf.')';
	488	}
	489	elsif ( $type eq NORMAL ) {
	490	$index_def =
08d91aad	491	"CREATE INDEX ${qf}${name}${qf} on ${qt}${table_name}${qt} (".
bfb5a568	492	join( ', ', map { qq[$qf$_$qf] } @fields ).
	493	');'
	494	;
	495	}
	496	else {
	497	warn "Unknown index type ($type) on table $table_name.\n"
	498	if $WARN;
	499	}
	500
	501	return $index_def, \@constraint_defs;
	502	}
	503
	504	sub create_constraint
	505	{
	506	my ($c, $options) = @_;
	507
	508	my $qf = $options->{quote_field_names} \|\|'';
	509	my $qt = $options->{quote_table_names} \|\|'';
	510	my $table_name = $c->table->name;
	511	my (@constraint_defs, @fks);
	512
	513	my $name = $c->name \|\| '';
	514	if ( $name ) {
	515	$name = next_unused_name($name, \%used_index_names);
	516	$used_index_names{$name} = $name;
	517	}
	518
	519	my @fields =
	520	map { $_ =~ s/\(.+\)//; $_ }
08d91aad	521	map { $qt ? $_ : unreserve( $_, $table_name )}
bfb5a568	522	$c->fields;
	523
	524	my @rfields =
	525	map { $_ =~ s/\(.+\)//; $_ }
08d91aad	526	map { $qt ? $_ : unreserve( $_, $table_name )}
bfb5a568	527	$c->reference_fields;
	528
	529	next if !@fields && $c->type ne CHECK_C;
	530	my $def_start = $name ? qq[Constraint "$name" ] : '';
	531	if ( $c->type eq PRIMARY_KEY ) {
	532	push @constraint_defs, "${def_start}PRIMARY KEY ".
	533	'('.$qf . join( $qf.', '.$qf, @fields ) . $qf.')';
	534	}
	535	elsif ( $c->type eq UNIQUE ) {
	536	$name = next_unused_name($name, \%used_index_names);
	537	$used_index_names{$name} = $name;
	538	push @constraint_defs, "${def_start}UNIQUE " .
	539	'('.$qf . join( $qf.', '.$qf, @fields ) . $qf.')';
	540	}
	541	elsif ( $c->type eq CHECK_C ) {
	542	my $expression = $c->expression;
	543	push @constraint_defs, "${def_start}CHECK ($expression)";
	544	}
	545	elsif ( $c->type eq FOREIGN_KEY ) {
	546	my $def .= "ALTER TABLE ${qt}${table_name}${qt} ADD FOREIGN KEY (" .
	547	join( ', ', map { qq[$qf$_$qf] } @fields ) . ')' .
	548	"\n REFERENCES " . $qt . $c->reference_table . $qt;
	549
	550	if ( @rfields ) {
	551	$def .= ' ('.$qf . join( $qf.', '.$qf, @rfields ) . $qf.')';
	552	}
	553
	554	if ( $c->match_type ) {
	555	$def .= ' MATCH ' .
	556	( $c->match_type =~ /full/i ) ? 'FULL' : 'PARTIAL';
	557	}
	558
	559	if ( $c->on_delete ) {
	560	$def .= ' ON DELETE '.join( ' ', $c->on_delete );
	561	}
	562
	563	if ( $c->on_update ) {
	564	$def .= ' ON UPDATE '.join( ' ', $c->on_update );
	565	}
	566
	567	push @fks, "$def;";
	568	}
	569
	570	return \@constraint_defs, \@fks;
	571	}
	572	}
	573
	574	sub convert_datatype
	575	{
	576	my ($field) = @_;
	577
	578	my @size = $field->size;
	579	my $data_type = lc $field->data_type;
	580
	581	if ( $data_type eq 'enum' ) {
	582	# my $len = 0;
	583	# $len = ($len < length($_)) ? length($_) : $len for (@$list);
	584	# my $chk_name = mk_name( $table_name.'_'.$field_name, 'chk' );
	585	# push @$constraint_defs,
	586	# qq[Constraint "$chk_name" CHECK ($qf$field_name$qf ].
	587	# qq[IN ($commalist))];
	588	$data_type = 'character varying';
	589	}
	590	elsif ( $data_type eq 'set' ) {
591	$data_type = 'character varying';
592	}
593	elsif ( $field->is_auto_increment ) {
594	if ( defined $size[0] && $size[0] > 11 ) {
595	$data_type = 'bigserial';
596	}
597	else {
598	$data_type = 'serial';
599	}
600	undef @size;
601	}
602	else {
603	$data_type = defined $translate{ $data_type } ?
604	$translate{ $data_type } :
605	$data_type;
606	}
607
608	if ( $data_type =~ /timestamp/i ) {
609	if ( defined $size[0] && $size[0] > 6 ) {
610	$size[0] = 6;
611	}
612	}
613
614	if ( $data_type eq 'integer' ) {
615	if ( defined $size[0] && $size[0] > 0) {
616	if ( $size[0] > 10 ) {
617	$data_type = 'bigint';
618	}
619	elsif ( $size[0] < 5 ) {
620	$data_type = 'smallint';
621	}
622	else {
623	$data_type = 'integer';
624	}
625	}
626	else {
627	$data_type = 'integer';
628	}
629	}
630
631	#
632	# PG doesn't need a size for integers or text
633	#
634	undef @size if $data_type =~ m/(integer\|smallint\|bigint\|text)/;
635
636	if ( defined $size[0] && $size[0] > 0 ) {
637	$data_type .= '(' . join( ',', @size ) . ')';
638	}
08d91aad	639	elsif (defined $size[0] && $data_type eq 'timestamp' ) {
	640	$data_type .= '(' . join( ',', @size ) . ')';
	641	}
bfb5a568	642
	643
	644	return $data_type;
	645	}
	646
	647
	648	sub alter_field
	649	{
	650	my ($from_field, $to_field) = @_;
	651
	652	die "Can't alter field in another table"
	653	if($from_field->table->name ne $to_field->table->name);
	654
	655	my @out;
	656	push @out, sprintf('ALTER TABLE %s ALTER COLUMN %s SET NOT NULL;',
	657	$to_field->table->name,
	658	$to_field->name) if(!$to_field->is_nullable and
	659	$from_field->is_nullable);
	660
	661	my $from_dt = convert_datatype($from_field);
	662	my $to_dt = convert_datatype($to_field);
	663	push @out, sprintf('ALTER TABLE %s ALTER COLUMN %s TYPE %s;',
	664	$to_field->table->name,
	665	$to_field->name,
	666	$to_dt) if($to_dt ne $from_dt);
	667
	668	push @out, sprintf('ALTER TABLE %s RENAME COLUMN %s TO %s;',
	669	$to_field->table->name,
	670	$from_field->name,
	671	$to_field->name) if($from_field->name ne $to_field->name);
	672
	673	push @out, sprintf('ALTER TABLE %s ALTER COLUMN %s SET DEFAULT %s;',
	674	$to_field->table->name,
	675	$to_field->name,
	676	$to_field->default_value)
	677	if(defined $to_field->default_value &&
	678	$from_field->default_value ne $to_field->default_value);
	679
	680	return wantarray ? @out : join("\n", @out);
	681
	682	}
	683
	684	sub add_field
	685	{
	686	my ($new_field) = @_;
	687
	688	my $out = sprintf('ALTER TABLE %s ADD COLUMN %s;',
	689	$new_field->table->name,
	690	create_field($new_field));
	691	return $out;
	692
	693	}
	694
	695	sub drop_field
	696	{
	697	my ($old_field) = @_;
	698
	699	my $out = sprintf('ALTER TABLE %s DROP COLUMN %s;',
	700	$old_field->table->name,
	701	$old_field->name);
	702
	703	return $out;
	704	}
	705
f8f0253c	706	1;
f8f0253c	707
96844cae	708	# -------------------------------------------------------------------
	709	# Life is full of misery, loneliness, and suffering --
	710	# and it's all over much too soon.
	711	# Woody Allen
	712	# -------------------------------------------------------------------
f8f0253c	713
96844cae	714	=pod
f8f0253c	715
20770e44	716	=head1 SEE ALSO
	717
	718	SQL::Translator, SQL::Translator::Producer::Oracle.
	719
f8f0253c	720	=head1 AUTHOR
f8f0253c	721
20770e44	722	Ken Y. Clark E<lt>kclark@cpan.orgE<gt>.
f8f0253c	723
f8f0253c	724	=cut