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

package SQL::Translator::Producer::DB2;

# -------------------------------------------------------------------
# $Id: DB2.pm,v 1.5 2006-11-10 21:21:51 mwz444 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::DB2 - DB2 SQL producer

=head1 SYNOPSIS

  use SQL::Translator;

  my $t = SQL::Translator->new( parser => '...', producer => 'DB2' );
  print $translator->translate( $file );

=head1 DESCRIPTION

Creates an SQL DDL suitable for DB2.

=cut

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

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


# http://publib.boulder.ibm.com/infocenter/db2help/topic/com.ibm.db2.udb.doc/ad/r0006844.htm

# This is a terrible WTDI, each Parser should parse down to some standard set
# of SQL data types, with field->extra entries being used to convert back to
# weird types like "polygon" if needed (IMO anyway)

my %dt_translate;
BEGIN {
  %dt_translate = (
    #
    # MySQL types
    #
    int        => 'integer',
    mediumint  => 'integer',
    tinyint    => 'smallint',
    char       => 'char',
    tinyblob   => 'blob',
    mediumblob => 'blob',
    longblob   => 'long varchar for bit data',
    tinytext   => 'varchar',
    text       => 'varchar',
    longtext   => 'varchar',
    mediumtext => 'varchar',
    enum       => 'varchar',
    set        => 'varchar',
    date       => 'date',
    datetime   => 'timestamp',
    time       => 'time',
    year       => 'date',

    #
    # PostgreSQL types
    #
    'double precision'  => 'double',
    serial              => 'integer',
    bigserial           => 'integer',
    money               => 'double',
    character           => 'char',
    'character varying' => 'varchar',
    bytea               => 'BLOB',
    interval            => 'integer',
    boolean             => 'smallint',
    point               => 'integer',
    line                => 'integer',
    lseg                => 'integer',
    box                 => 'integer',
    path                => 'integer',
    polygon             => 'integer',
    circle              => 'integer',
    cidr                => 'integer',
    inet                => 'varchar',
    macaddr             => 'varchar',
    bit                 => 'number',
    'bit varying'       => 'number',

    #
    # DB types
    #
    number              => 'integer',
    varchar2            => 'varchar',
    long                => 'clob',
);
}

my %db2_reserved = map { $_ => 1} qw/
ADD                DETERMINISTIC  LEAVE         RESTART
AFTER              DISALLOW       LEFT          RESTRICT
ALIAS              DISCONNECT     LIKE          RESULT
ALL                DISTINCT       LINKTYPE      RESULT_SET_LOCATOR
ALLOCATE           DO             LOCAL         RETURN
ALLOW              DOUBLE         LOCALE        RETURNS
ALTER              DROP           LOCATOR       REVOKE
AND                DSNHATTR       LOCATORS      RIGHT
ANY                DSSIZE         LOCK          ROLLBACK
APPLICATION        DYNAMIC        LOCKMAX       ROUTINE
AS                 EACH           LOCKSIZE      ROW
ASSOCIATE          EDITPROC       LONG          ROWS
ASUTIME            ELSE           LOOP          RRN
AUDIT              ELSEIF         MAXVALUE      RUN
AUTHORIZATION      ENCODING       MICROSECOND   SAVEPOINT
AUX                END            MICROSECONDS  SCHEMA
AUXILIARY          END-EXEC       MINUTE        SCRATCHPAD
BEFORE             END-EXEC1      MINUTES       SECOND
BEGIN              ERASE          MINVALUE      SECONDS
BETWEEN            ESCAPE         MODE          SECQTY
BINARY             EXCEPT         MODIFIES      SECURITY
BUFFERPOOL         EXCEPTION      MONTH         SELECT
BY                 EXCLUDING      MONTHS        SENSITIVE
CACHE              EXECUTE        NEW           SET
CALL               EXISTS         NEW_TABLE     SIGNAL
CALLED             EXIT           NO            SIMPLE
CAPTURE            EXTERNAL       NOCACHE       SOME
CARDINALITY        FENCED         NOCYCLE       SOURCE
CASCADED           FETCH          NODENAME      SPECIFIC
CASE               FIELDPROC      NODENUMBER    SQL
CAST               FILE           NOMAXVALUE    SQLID
CCSID              FINAL          NOMINVALUE    STANDARD
CHAR               FOR            NOORDER       START
CHARACTER          FOREIGN        NOT           STATIC
CHECK              FREE           NULL          STAY
CLOSE              FROM           NULLS         STOGROUP
CLUSTER            FULL           NUMPARTS      STORES
COLLECTION         FUNCTION       OBID          STYLE
COLLID             GENERAL        OF            SUBPAGES
COLUMN             GENERATED      OLD           SUBSTRING
COMMENT            GET            OLD_TABLE     SYNONYM
COMMIT             GLOBAL         ON            SYSFUN
CONCAT             GO             OPEN          SYSIBM
CONDITION          GOTO           OPTIMIZATION  SYSPROC
CONNECT            GRANT          OPTIMIZE      SYSTEM
CONNECTION         GRAPHIC        OPTION        TABLE
CONSTRAINT         GROUP          OR            TABLESPACE
CONTAINS           HANDLER        ORDER         THEN
CONTINUE           HAVING         OUT           TO
COUNT              HOLD           OUTER         TRANSACTION
COUNT_BIG          HOUR           OVERRIDING    TRIGGER
CREATE             HOURS          PACKAGE       TRIM
CROSS              IDENTITY       PARAMETER     TYPE
CURRENT            IF             PART          UNDO
CURRENT_DATE       IMMEDIATE      PARTITION     UNION
CURRENT_LC_CTYPE   IN             PATH          UNIQUE
CURRENT_PATH       INCLUDING      PIECESIZE     UNTIL
CURRENT_SERVER     INCREMENT      PLAN          UPDATE
CURRENT_TIME       INDEX          POSITION      USAGE
CURRENT_TIMESTAMP  INDICATOR      PRECISION     USER
CURRENT_TIMEZONE   INHERIT        PREPARE       USING
CURRENT_USER       INNER          PRIMARY       VALIDPROC
CURSOR             INOUT          PRIQTY        VALUES
CYCLE              INSENSITIVE    PRIVILEGES    VARIABLE
DATA               INSERT         PROCEDURE     VARIANT
DATABASE           INTEGRITY      PROGRAM       VCAT
DAY                INTO           PSID          VIEW
DAYS               IS             QUERYNO       VOLUMES
DB2GENERAL         ISOBID         READ          WHEN
DB2GENRL           ISOLATION      READS         WHERE
DB2SQL             ITERATE        RECOVERY      WHILE
DBINFO             JAR            REFERENCES    WITH
DECLARE            JAVA           REFERENCING   WLM
DEFAULT            JOIN           RELEASE       WRITE
DEFAULTS           KEY            RENAME        YEAR
DEFINITION         LABEL          REPEAT        YEARS
DELETE             LANGUAGE       RESET
DESCRIPTOR         LC_CTYPE       RESIGNAL 
/;

#------------------------------------------------------------------------------

sub produce
{
    my ($translator) = @_;
    $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 $output         = '';
    my $indent         = '    ';

    $output .= header_comment unless($no_comments);
    my (@table_defs, @fks, @index_defs);
    foreach my $table ($schema->get_tables)
    {
        push @table_defs, 'DROP TABLE ' . $table->name . ";" if $add_drop_table;
        my ($table_def, $fks) = create_table($table, {
            no_comments => $no_comments});
        push @table_defs, $table_def;
        push @fks, @$fks;

        foreach my $index ($table->get_indices)
        {
            push @index_defs, create_index($index);
        }

    }   
    my (@view_defs);
    foreach my $view ( $schema->get_views )
    {
        push @view_defs, create_view($view);
    }
    my (@trigger_defs);
    foreach my $trigger ( $schema->get_triggers )
    {
        push @trigger_defs, create_trigger($trigger);
    }

    return wantarray ? (@table_defs, @fks, @index_defs, @view_defs, @trigger_defs) :
        $output . join("\n\n", @table_defs, @fks, @index_defs, @view_defs, @trigger_defs) . "\n";
}

{ my %objnames;

    sub check_name
    {
        my ($name, $type, $length) = @_;

        my $newname = $name;
        if(length($name) > $length)   ## Maximum table name length is 18
        {
            warn "Table name $name is longer than $length characters, truncated" if $WARN;
#             if(grep {$_ eq substr($name, 0, $length) } 
#                               values(%{$objnames{$type}}))
#             {
#                 die "Got multiple matching table names when truncated";
#             }
#             $objnames{$type}{$name} = substr($name, 0,$length);
#             $newname = $objnames{$type}{$name};
        }

        if($db2_reserved{uc($newname)})
        {
            warn "$newname is a reserved word in DB2!" if $WARN;
        }

#        return sprintf("%-*s", $length-5, $newname);
        return $newname;
    }
}

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

    my $table_name = check_name($table->name, 'tables', 128); 
    # this limit is 18 in older DB2s ! (<= 8)

    my (@field_defs, @comments);
    push @comments, "--\n-- Table: $table_name\n--" unless $options->{no_comments};
    foreach my $field ($table->get_fields)
    {
        push @field_defs, create_field($field);
    }
    my (@con_defs, @fks);
    foreach my $con ($table->get_constraints)
    {
        my ($cdefs, $fks) = create_constraint($con);
        push @con_defs, @$cdefs;
        push @fks, @$fks;
    }

    my $tablespace = $table->extra()->{'TABLESPACE'} || '';
    my $table_def = "CREATE TABLE $table_name (\n";
    $table_def .= join (",\n", map { "  $_" } @field_defs, @con_defs);
    $table_def .= "\n)";
    $table_def .= $tablespace ? "IN $tablespace;" : ';';

    return $table_def, \@fks;
}

sub create_field
{
    my ($field) = @_;
    
    my $field_name = check_name($field->name, 'fields', 30);
#    use Data::Dumper;
#    print Dumper(\%dt_translate);
#    print $field->data_type, " ", $dt_translate{lc($field->data_type)}, "\n";
    my $data_type = uc($dt_translate{lc($field->data_type)} || $field->data_type);
    my $size = $field->size();

    my $field_def = "$field_name $data_type";
    $field_def .= $field->is_auto_increment ? 
        ' GENERATED BY DEFAULT AS IDENTITY (START WITH 1, INCREMENT BY 1)' : '';
    $field_def .= $data_type =~ /(CHAR|CLOB)/i ? "(${size})" : '';
    $field_def .= !$field->is_nullable ? ' NOT NULL':'';
#            $field_def .= $field->is_primary_key ? ' PRIMARY KEY':'';
    $field_def .= !defined $field->default_value ? '' : 
        $field->default_value =~ /current( |_)timestamp/i ||
        $field->default_value =~ /\Qnow()\E/i ? 
        ' DEFAULT CURRENT TIMESTAMP' : defined $field->default_value ?
        (" DEFAULT " . ($data_type =~ /(INT|DOUBLE)/i ? 
                        $field->default_value : "'" . $field->default_value . "'")
         ) : '';

    return $field_def;
}

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

    my $out = sprintf('CREATE %sINDEX %s ON %s ( %s );',
                      $index->type() =~ /^UNIQUE$/i ? 'UNIQUE' : '',
                      $index->name,
                      $index->table->name,
                      join(', ', $index->fields) );

    return $out;
}

sub create_constraint
{
    my ($constraint) = @_;

    my (@con_defs, @fks);

    my $ctype =  $constraint->type =~ /^PRIMARY(_|\s)KEY$/i ? 'PRIMARY KEY' :
                 $constraint->type =~ /^UNIQUE$/i      ? 'UNIQUE' :
                 $constraint->type =~ /^CHECK_C$/i     ? 'CHECK' :
                 $constraint->type =~ /^FOREIGN(_|\s)KEY$/i ? 'FOREIGN KEY' : '';

    my $expr = $constraint->type =~ /^CHECK_C$/i ? $constraint->expression :
        '';
    my $ref = $constraint->type =~ /^FOREIGN(_|\s)KEY$/i ? ('REFERENCES ' . $constraint->reference_table . '(' . join(', ', $constraint->reference_fields) . ')') : '';
    my $update = $constraint->on_update ? $constraint->on_update : '';
    my $delete = $constraint->on_delete ? $constraint->on_delete : '';

    my $out = join(' ', grep { $_ }
                      $constraint->name ? ('CONSTRAINT ' . $constraint->name) : '',
                      $ctype,
                      '(' . join (', ', $constraint->fields) . ')',
                      $expr ? $expr : $ref,
                      $update,
                      $delete);
    if ($constraint->type eq FOREIGN_KEY) {
        my $table_name = $constraint->table->name;
        $out = "ALTER TABLE $table_name ADD $out;";
        push @fks, $out;
    }
    else {
        push @con_defs, $out;
    }

    return \@con_defs, \@fks;
                      
}

sub create_view
{
    my ($view) = @_;

    my $out = sprintf("CREATE VIEW %s AS\n%s;",
                      $view->name,
                      $view->sql);

    return $out;
}

sub create_trigger
{
    my ($trigger) = @_;
# create: CREATE TRIGGER trigger_name before type /ON/i table_name reference_b(?) /FOR EACH ROW/i 'MODE DB2SQL' triggered_action

    my $out = sprintf('CREATE TRIGGER %s %s %s ON %s %s %s MODE DB2SQL %s',
                      $trigger->name,
                      $trigger->perform_action_when || 'AFTER',
                      $trigger->database_event =~ /update_on/i ? 
                        ('UPDATE OF '. join(', ', $trigger->fields)) :
                        $trigger->database_event || 'UPDATE',
                      $trigger->table->name,
                      $trigger->extra->{reference} || 'REFERENCING OLD AS oldrow NEW AS newrow',
                      $trigger->extra->{granularity} || 'FOR EACH ROW',
                      $trigger->action );

    return $out;
                      
}

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

    my $data_type = uc($dt_translate{lc($to_field->data_type)} || $to_field->data_type);

    my $size = $to_field->size();
    $data_type .= $data_type =~ /CHAR/i ? "(${size})" : '';

    # DB2 will only allow changing of varchar/vargraphic datatypes
    # to extend their lengths. Or changing of text types to other
    # texttypes, and numeric types to larger numeric types. (v8)
    # We can also drop/add keys, checks and constraints, but not
    # columns !?

    my $out = sprintf('ALTER TABLE %s ALTER %s SET DATATYPE %s',
                      $to_field->table->name,
                      $to_field->name,
                      $data_type);

}

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 ($field) = @_;

    return '';
}
1;
Commit	Line	Data
04bc93b6	1	package SQL::Translator::Producer::DB2;
	2
	3	# -------------------------------------------------------------------
b08b5416	4	# $Id: DB2.pm,v 1.5 2006-11-10 21:21:51 mwz444 Exp $
04bc93b6	5	# -------------------------------------------------------------------
	6	# Copyright (C) 2002-4 SQLFairy Authors
	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	# -------------------------------------------------------------------
04bc93b6	22	=head1 NAME
	23
	24	SQL::Translator::Producer::DB2 - DB2 SQL producer
	25
	26	=head1 SYNOPSIS
	27
	28	use SQL::Translator;
	29
	30	my $t = SQL::Translator->new( parser => '...', producer => 'DB2' );
	31	print $translator->translate( $file );
	32
	33	=head1 DESCRIPTION
	34
a0ea6c87	35	Creates an SQL DDL suitable for DB2.
04bc93b6	36
	37	=cut
	38
a0ea6c87	39	use warnings;
04bc93b6	40	use strict;
04bc93b6	41	use vars qw[ $VERSION $DEBUG $WARN ];
b08b5416	42	$VERSION = sprintf "%d.%02d", q$Revision: 1.5 $ =~ /(\d+)\.(\d+)/;
04bc93b6	43	$DEBUG = 0 unless defined $DEBUG;
	44
	45	use SQL::Translator::Schema::Constants;
	46	use SQL::Translator::Utils qw(header_comment);
	47
	48
	49	# http://publib.boulder.ibm.com/infocenter/db2help/topic/com.ibm.db2.udb.doc/ad/r0006844.htm
	50
	51	# This is a terrible WTDI, each Parser should parse down to some standard set
	52	# of SQL data types, with field->extra entries being used to convert back to
	53	# weird types like "polygon" if needed (IMO anyway)
	54
3866f0ff	55	my %dt_translate;
5e2c196a	56	BEGIN {
5e2c196a	57	%dt_translate = (
04bc93b6	58	#
	59	# MySQL types
	60	#
	61	int => 'integer',
	62	mediumint => 'integer',
	63	tinyint => 'smallint',
	64	char => 'char',
	65	tinyblob => 'blob',
	66	mediumblob => 'blob',
	67	longblob => 'long varchar for bit data',
	68	tinytext => 'varchar',
a0ea6c87	69	text => 'varchar',
	70	longtext => 'varchar',
	71	mediumtext => 'varchar',
04bc93b6	72	enum => 'varchar',
	73	set => 'varchar',
	74	date => 'date',
	75	datetime => 'timestamp',
	76	time => 'time',
	77	year => 'date',
	78
	79	#
	80	# PostgreSQL types
	81	#
	82	'double precision' => 'double',
	83	serial => 'integer',
	84	bigserial => 'integer',
	85	money => 'double',
	86	character => 'char',
	87	'character varying' => 'varchar',
	88	bytea => 'BLOB',
	89	interval => 'integer',
	90	boolean => 'smallint',
	91	point => 'integer',
	92	line => 'integer',
	93	lseg => 'integer',
	94	box => 'integer',
	95	path => 'integer',
	96	polygon => 'integer',
	97	circle => 'integer',
	98	cidr => 'integer',
	99	inet => 'varchar',
	100	macaddr => 'varchar',
	101	bit => 'number',
	102	'bit varying' => 'number',
	103
	104	#
	105	# DB types
	106	#
	107	number => 'integer',
	108	varchar2 => 'varchar',
	109	long => 'clob',
	110	);
5e2c196a	111	}
04bc93b6	112
	113	my %db2_reserved = map { $_ => 1} qw/
	114	ADD DETERMINISTIC LEAVE RESTART
	115	AFTER DISALLOW LEFT RESTRICT
	116	ALIAS DISCONNECT LIKE RESULT
	117	ALL DISTINCT LINKTYPE RESULT_SET_LOCATOR
	118	ALLOCATE DO LOCAL RETURN
	119	ALLOW DOUBLE LOCALE RETURNS
	120	ALTER DROP LOCATOR REVOKE
	121	AND DSNHATTR LOCATORS RIGHT
	122	ANY DSSIZE LOCK ROLLBACK
	123	APPLICATION DYNAMIC LOCKMAX ROUTINE
	124	AS EACH LOCKSIZE ROW
	125	ASSOCIATE EDITPROC LONG ROWS
	126	ASUTIME ELSE LOOP RRN
	127	AUDIT ELSEIF MAXVALUE RUN
	128	AUTHORIZATION ENCODING MICROSECOND SAVEPOINT
	129	AUX END MICROSECONDS SCHEMA
	130	AUXILIARY END-EXEC MINUTE SCRATCHPAD
	131	BEFORE END-EXEC1 MINUTES SECOND
	132	BEGIN ERASE MINVALUE SECONDS
	133	BETWEEN ESCAPE MODE SECQTY
	134	BINARY EXCEPT MODIFIES SECURITY
	135	BUFFERPOOL EXCEPTION MONTH SELECT
	136	BY EXCLUDING MONTHS SENSITIVE
	137	CACHE EXECUTE NEW SET
	138	CALL EXISTS NEW_TABLE SIGNAL
	139	CALLED EXIT NO SIMPLE
	140	CAPTURE EXTERNAL NOCACHE SOME
	141	CARDINALITY FENCED NOCYCLE SOURCE
	142	CASCADED FETCH NODENAME SPECIFIC
	143	CASE FIELDPROC NODENUMBER SQL
	144	CAST FILE NOMAXVALUE SQLID
	145	CCSID FINAL NOMINVALUE STANDARD
	146	CHAR FOR NOORDER START
	147	CHARACTER FOREIGN NOT STATIC
	148	CHECK FREE NULL STAY
	149	CLOSE FROM NULLS STOGROUP
	150	CLUSTER FULL NUMPARTS STORES
	151	COLLECTION FUNCTION OBID STYLE
	152	COLLID GENERAL OF SUBPAGES
	153	COLUMN GENERATED OLD SUBSTRING
	154	COMMENT GET OLD_TABLE SYNONYM
	155	COMMIT GLOBAL ON SYSFUN
	156	CONCAT GO OPEN SYSIBM
	157	CONDITION GOTO OPTIMIZATION SYSPROC
	158	CONNECT GRANT OPTIMIZE SYSTEM
	159	CONNECTION GRAPHIC OPTION TABLE
	160	CONSTRAINT GROUP OR TABLESPACE
	161	CONTAINS HANDLER ORDER THEN
	162	CONTINUE HAVING OUT TO
	163	COUNT HOLD OUTER TRANSACTION
	164	COUNT_BIG HOUR OVERRIDING TRIGGER
	165	CREATE HOURS PACKAGE TRIM
	166	CROSS IDENTITY PARAMETER TYPE
	167	CURRENT IF PART UNDO
	168	CURRENT_DATE IMMEDIATE PARTITION UNION
	169	CURRENT_LC_CTYPE IN PATH UNIQUE
	170	CURRENT_PATH INCLUDING PIECESIZE UNTIL
	171	CURRENT_SERVER INCREMENT PLAN UPDATE
	172	CURRENT_TIME INDEX POSITION USAGE
	173	CURRENT_TIMESTAMP INDICATOR PRECISION USER
	174	CURRENT_TIMEZONE INHERIT PREPARE USING
	175	CURRENT_USER INNER PRIMARY VALIDPROC
176	CURSOR INOUT PRIQTY VALUES
177	CYCLE INSENSITIVE PRIVILEGES VARIABLE
178	DATA INSERT PROCEDURE VARIANT
179	DATABASE INTEGRITY PROGRAM VCAT
180	DAY INTO PSID VIEW
181	DAYS IS QUERYNO VOLUMES
182	DB2GENERAL ISOBID READ WHEN
183	DB2GENRL ISOLATION READS WHERE
184	DB2SQL ITERATE RECOVERY WHILE
185	DBINFO JAR REFERENCES WITH
186	DECLARE JAVA REFERENCING WLM
187	DEFAULT JOIN RELEASE WRITE
188	DEFAULTS KEY RENAME YEAR
189	DEFINITION LABEL REPEAT YEARS
190	DELETE LANGUAGE RESET
191	DESCRIPTOR LC_CTYPE RESIGNAL
192	/;
193
194	#------------------------------------------------------------------------------
195
196	sub produce
197	{
198	my ($translator) = @_;
199	$DEBUG = $translator->debug;
200	$WARN = $translator->show_warnings;
201	my $no_comments = $translator->no_comments;
202	my $add_drop_table = $translator->add_drop_table;
203	my $schema = $translator->schema;
204	my $output = '';
205	my $indent = ' ';
206
207	$output .= header_comment unless($no_comments);
b08b5416	208	my (@table_defs, @fks, @index_defs);
04bc93b6	209	foreach my $table ($schema->get_tables)
04bc93b6	210	{
5e2c196a	211	push @table_defs, 'DROP TABLE ' . $table->name . ";" if $add_drop_table;
b08b5416	212	my ($table_def, $fks) = create_table($table, {
a0ea6c87	213	no_comments => $no_comments});
b08b5416	214	push @table_defs, $table_def;
b08b5416	215	push @fks, @$fks;
04bc93b6	216
a0ea6c87	217	foreach my $index ($table->get_indices)
04bc93b6	218	{
a0ea6c87	219	push @index_defs, create_index($index);
04bc93b6	220	}
a0ea6c87	221
04bc93b6	222	}
a0ea6c87	223	my (@view_defs);
	224	foreach my $view ( $schema->get_views )
	225	{
	226	push @view_defs, create_view($view);
	227	}
	228	my (@trigger_defs);
	229	foreach my $trigger ( $schema->get_triggers )
	230	{
	231	push @trigger_defs, create_trigger($trigger);
	232	}
04bc93b6	233
b08b5416	234	return wantarray ? (@table_defs, @fks, @index_defs, @view_defs, @trigger_defs) :
b08b5416	235	$output . join("\n\n", @table_defs, @fks, @index_defs, @view_defs, @trigger_defs) . "\n";
04bc93b6	236	}
	237
	238	{ my %objnames;
	239
	240	sub check_name
	241	{
	242	my ($name, $type, $length) = @_;
	243
	244	my $newname = $name;
	245	if(length($name) > $length) ## Maximum table name length is 18
	246	{
	247	warn "Table name $name is longer than $length characters, truncated" if $WARN;
a0ea6c87	248	# if(grep {$_ eq substr($name, 0, $length) }
	249	# values(%{$objnames{$type}}))
	250	# {
	251	# die "Got multiple matching table names when truncated";
	252	# }
	253	# $objnames{$type}{$name} = substr($name, 0,$length);
	254	# $newname = $objnames{$type}{$name};
04bc93b6	255	}
	256
	257	if($db2_reserved{uc($newname)})
	258	{
	259	warn "$newname is a reserved word in DB2!" if $WARN;
	260	}
	261
5e2c196a	262	# return sprintf("%-*s", $length-5, $newname);
5e2c196a	263	return $newname;
04bc93b6	264	}
	265	}
	266
a0ea6c87	267	sub create_table
	268	{
	269	my ($table, $options) = @_;
	270
	271	my $table_name = check_name($table->name, 'tables', 128);
	272	# this limit is 18 in older DB2s ! (<= 8)
	273
	274	my (@field_defs, @comments);
	275	push @comments, "--\n-- Table: $table_name\n--" unless $options->{no_comments};
	276	foreach my $field ($table->get_fields)
	277	{
	278	push @field_defs, create_field($field);
	279	}
b08b5416	280	my (@con_defs, @fks);
a0ea6c87	281	foreach my $con ($table->get_constraints)
a0ea6c87	282	{
b08b5416	283	my ($cdefs, $fks) = create_constraint($con);
	284	push @con_defs, @$cdefs;
	285	push @fks, @$fks;
a0ea6c87	286	}
a0ea6c87	287
	288	my $tablespace = $table->extra()->{'TABLESPACE'} \|\| '';
	289	my $table_def = "CREATE TABLE $table_name (\n";
b08b5416	290	$table_def .= join (",\n", map { " $_" } @field_defs, @con_defs);
a0ea6c87	291	$table_def .= "\n)";
	292	$table_def .= $tablespace ? "IN $tablespace;" : ';';
	293
b08b5416	294	return $table_def, \@fks;
a0ea6c87	295	}
	296
	297	sub create_field
	298	{
	299	my ($field) = @_;
	300
	301	my $field_name = check_name($field->name, 'fields', 30);
	302	# use Data::Dumper;
	303	# print Dumper(\%dt_translate);
	304	# print $field->data_type, " ", $dt_translate{lc($field->data_type)}, "\n";
	305	my $data_type = uc($dt_translate{lc($field->data_type)} \|\| $field->data_type);
	306	my $size = $field->size();
	307
	308	my $field_def = "$field_name $data_type";
	309	$field_def .= $field->is_auto_increment ?
3866f0ff	310	' GENERATED BY DEFAULT AS IDENTITY (START WITH 1, INCREMENT BY 1)' : '';
b08b5416	311	$field_def .= $data_type =~ /(CHAR\|CLOB)/i ? "(${size})" : '';
a0ea6c87	312	$field_def .= !$field->is_nullable ? ' NOT NULL':'';
	313	# $field_def .= $field->is_primary_key ? ' PRIMARY KEY':'';
	314	$field_def .= !defined $field->default_value ? '' :
	315	$field->default_value =~ /current( \|_)timestamp/i \|\|
	316	$field->default_value =~ /\Qnow()\E/i ?
b08b5416	317	' DEFAULT CURRENT TIMESTAMP' : defined $field->default_value ?
	318	(" DEFAULT " . ($data_type =~ /(INT\|DOUBLE)/i ?
	319	$field->default_value : "'" . $field->default_value . "'")
	320	) : '';
a0ea6c87	321
5e2c196a	322	return $field_def;
a0ea6c87	323	}
	324
	325	sub create_index
	326	{
	327	my ($index) = @_;
	328
	329	my $out = sprintf('CREATE %sINDEX %s ON %s ( %s );',
	330	$index->type() =~ /^UNIQUE$/i ? 'UNIQUE' : '',
	331	$index->name,
	332	$index->table->name,
	333	join(', ', $index->fields) );
	334
	335	return $out;
	336	}
	337
	338	sub create_constraint
	339	{
	340	my ($constraint) = @_;
	341
b08b5416	342	my (@con_defs, @fks);
a0ea6c87	343
	344	my $ctype = $constraint->type =~ /^PRIMARY(_\|\s)KEY$/i ? 'PRIMARY KEY' :
	345	$constraint->type =~ /^UNIQUE$/i ? 'UNIQUE' :
	346	$constraint->type =~ /^CHECK_C$/i ? 'CHECK' :
b08b5416	347	$constraint->type =~ /^FOREIGN(_\|\s)KEY$/i ? 'FOREIGN KEY' : '';
a0ea6c87	348
	349	my $expr = $constraint->type =~ /^CHECK_C$/i ? $constraint->expression :
	350	'';
b08b5416	351	my $ref = $constraint->type =~ /^FOREIGN(_\|\s)KEY$/i ? ('REFERENCES ' . $constraint->reference_table . '(' . join(', ', $constraint->reference_fields) . ')') : '';
a0ea6c87	352	my $update = $constraint->on_update ? $constraint->on_update : '';
	353	my $delete = $constraint->on_delete ? $constraint->on_delete : '';
	354
b08b5416	355	my $out = join(' ', grep { $_ }
a0ea6c87	356	$constraint->name ? ('CONSTRAINT ' . $constraint->name) : '',
	357	$ctype,
	358	'(' . join (', ', $constraint->fields) . ')',
	359	$expr ? $expr : $ref,
	360	$update,
	361	$delete);
b08b5416	362	if ($constraint->type eq FOREIGN_KEY) {
	363	my $table_name = $constraint->table->name;
	364	$out = "ALTER TABLE $table_name ADD $out;";
	365	push @fks, $out;
	366	}
	367	else {
	368	push @con_defs, $out;
	369	}
a0ea6c87	370
b08b5416	371	return \@con_defs, \@fks;
a0ea6c87	372
	373	}
	374
	375	sub create_view
	376	{
	377	my ($view) = @_;
	378
	379	my $out = sprintf("CREATE VIEW %s AS\n%s;",
	380	$view->name,
	381	$view->sql);
	382
	383	return $out;
	384	}
	385
	386	sub create_trigger
	387	{
	388	my ($trigger) = @_;
	389	# create: CREATE TRIGGER trigger_name before type /ON/i table_name reference_b(?) /FOR EACH ROW/i 'MODE DB2SQL' triggered_action
	390
	391	my $out = sprintf('CREATE TRIGGER %s %s %s ON %s %s %s MODE DB2SQL %s',
	392	$trigger->name,
	393	$trigger->perform_action_when \|\| 'AFTER',
	394	$trigger->database_event =~ /update_on/i ?
	395	('UPDATE OF '. join(', ', $trigger->fields)) :
	396	$trigger->database_event \|\| 'UPDATE',
5e2c196a	397	$trigger->table->name,
a0ea6c87	398	$trigger->extra->{reference} \|\| 'REFERENCING OLD AS oldrow NEW AS newrow',
	399	$trigger->extra->{granularity} \|\| 'FOR EACH ROW',
	400	$trigger->action );
	401
	402	return $out;
	403
	404	}
	405
	406	sub alter_field
	407	{
	408	my ($from_field, $to_field) = @_;
5e2c196a	409
	410	my $data_type = uc($dt_translate{lc($to_field->data_type)} \|\| $to_field->data_type);
	411
	412	my $size = $to_field->size();
	413	$data_type .= $data_type =~ /CHAR/i ? "(${size})" : '';
	414
	415	# DB2 will only allow changing of varchar/vargraphic datatypes
	416	# to extend their lengths. Or changing of text types to other
	417	# texttypes, and numeric types to larger numeric types. (v8)
	418	# We can also drop/add keys, checks and constraints, but not
	419	# columns !?
	420
	421	my $out = sprintf('ALTER TABLE %s ALTER %s SET DATATYPE %s',
	422	$to_field->table->name,
	423	$to_field->name,
	424	$data_type);
	425
a0ea6c87	426	}
	427
	428	sub add_field
	429	{
5e2c196a	430	my ($new_field) = @_;
	431
	432	my $out = sprintf('ALTER TABLE %s ADD COLUMN %s',
	433	$new_field->table->name,
	434	create_field($new_field));
	435
	436	return $out;
a0ea6c87	437	}
	438
	439	sub drop_field
	440	{
	441	my ($field) = @_;
5e2c196a	442
5e2c196a	443	return '';
a0ea6c87	444	}
04bc93b6	445	1;