lib/SQL/Translator/Producer/SQLite.pm

   1 package SQL::Translator::Producer::SQLite;
   2
   3 # -------------------------------------------------------------------
   4 # $Id: SQLite.pm,v 1.5 2003-06-11 04:00:44 kycl4rk Exp $
   5 # -------------------------------------------------------------------
   6 # Copyright (C) 2003 Ken Y. Clark <kclark@cpan.org>,
   7 #                    darren chamberlain <darren@cpan.org>,
   8 #                    Chris Mungall <cjm@fruitfly.org>
   9 #
  10 # This program is free software; you can redistribute it and/or
  11 # modify it under the terms of the GNU General Public License as
  12 # published by the Free Software Foundation; version 2.
  13 #
  14 # This program is distributed in the hope that it will be useful, but
  15 # WITHOUT ANY WARRANTY; without even the implied warranty of
  16 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  17 # General Public License for more details.
  18 #
  19 # You should have received a copy of the GNU General Public License
  20 # along with this program; if not, write to the Free Software
  21 # Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA
  22 # 02111-1307  USA
  23 # -------------------------------------------------------------------
  24
  25 use strict;
  26 use Data::Dumper;
  27 use SQL::Translator::Schema::Constants;
  28 use SQL::Translator::Utils qw(debug header_comment);
  29
  30 use vars qw[ $VERSION $DEBUG $WARN ];
  31
  32 $VERSION = sprintf "%d.%02d", q$Revision: 1.5 $ =~ /(\d+)\.(\d+)/;
  33 $DEBUG = 0 unless defined $DEBUG;
  34 $WARN = 0 unless defined $WARN;
  35
  36 my %used_identifiers = ();
  37 my $max_id_length    = 30;
  38 my %global_names;
  39 my %truncated;
  40
  41 sub produce {
  42     my $translator     = shift;
  43     local $DEBUG       = $translator->debug;
  44     local $WARN        = $translator->show_warnings;
  45     my $no_comments    = $translator->no_comments;
  46     my $add_drop_table = $translator->add_drop_table;
  47     my $schema         = $translator->schema;
  48
  49     debug("PKG: Beginning production\n");
  50
  51     my $create = '';
  52     $create .= header_comment unless ($no_comments);
  53
  54     for my $table ( $schema->get_tables ) {
  55         my $table_name = $table->name;
  56         debug("PKG: Looking at table '$table_name'\n");
  57
  58         my @fields = $table->get_fields or die "No fields in $table_name";
  59
  60         #
  61         # Header.
  62         #
  63         $create .= "--\n-- Table: $table_name\n--\n" unless $no_comments;
  64         $create .= qq[DROP TABLE $table_name;\n] if $add_drop_table;
  65         $create .= "CREATE TABLE $table_name (\n";
  66
  67         #
  68         # Fields
  69         #
  70         my @field_defs;
  71         for my $field ( @fields ) {
  72             my $field_name = $field->name;
  73             debug("PKG: Looking at field '$field_name'\n");
  74             my $field_def = $field_name;
  75
  76             # data type and size
  77             my $size      = $field->size;
  78             my $data_type = $field->data_type;
  79             $data_type    = 'varchar' if lc $data_type eq 'set';
  80
  81             #
  82             # SQLite is generally typeless, but newer versions will
  83             # make a field autoincrement if it is declared as (and
  84             # *only* as) INTEGER PRIMARY KEY
  85             #
  86             if ( $field->is_auto_increment && $field->is_primary_key ) {
  87                 $data_type = 'INTEGER PRIMARY KEY';
  88             }
  89
  90             $field_def .= sprintf " %s%s", $data_type,
  91                 ( !$field->is_auto_increment && $size ) ? "($size)" : '';
  92
  93             # Null?
  94             $field_def .= ' NOT NULL' unless $field->is_nullable;
  95
  96             # Default?  XXX Need better quoting!
  97             my $default = $field->default_value;
  98             if ( defined $default ) {
  99                 if ( uc $default eq 'NULL') {
 100                     $field_def .= ' DEFAULT NULL';
 101                 } else {
 102                     $field_def .= " DEFAULT '$default'";
 103                 }
 104             }
 105
 106             push @field_defs, $field_def;
 107         }
 108
 109         #
 110         # Indices
 111         #
 112         my @index_defs;
 113         my $idx_name_default = 'A';
 114         for my $index ( $table->get_indices ) {
 115             my $name   = $index->name;
 116             $name      = mk_name($table_name, $name || ++$idx_name_default);
 117             my @fields = $index->fields;
 118             push @index_defs,
 119                 "CREATE INDEX $name on $table_name ".
 120                 '(' . join( ', ', @fields ) . ')';
 121         }
 122
 123         #
 124         # Constraints
 125         #
 126         my @constraint_defs;
 127         my $c_name_default = 'A';
 128         for my $c ( $table->get_constraints ) {
 129             next unless $c->type eq UNIQUE;
 130             my $name   = $c->name;
 131             $name      = mk_name($table_name, $name || ++$idx_name_default);
 132             my @fields = $c->fields;
 133
 134             push @constraint_defs,
 135                 "CREATE UNIQUE INDEX $name on $table_name ".
 136                 '(' . join( ', ', @fields ) . ')';
 137         }
 138
 139         $create .= join(",\n", map { "  $_" } @field_defs ) . "\n);\n";
 140
 141         for my $index_create ( @index_defs, @constraint_defs ) {
 142             $create .= "$index_create;\n";
 143         }
 144
 145         $create .= "\n";
 146     }
 147
 148     return $create;
 149 }
 150
 151 # -------------------------------------------------------------------
 152 sub mk_name {
 153     my ($basename, $type, $scope, $critical) = @_;
 154     my $basename_orig = $basename;
 155     my $max_name      = $type
 156                         ? $max_id_length - (length($type) + 1)
 157                         : $max_id_length;
 158     $basename         = substr( $basename, 0, $max_name )
 159                         if length( $basename ) > $max_name;
 160     my $name          = $type ? "${type}_$basename" : $basename;
 161
 162     if ( $basename ne $basename_orig and $critical ) {
 163         my $show_type = $type ? "+'$type'" : "";
 164         warn "Truncating '$basename_orig'$show_type to $max_id_length ",
 165             "character limit to make '$name'\n" if $WARN;
 166         $truncated{ $basename_orig } = $name;
 167     }
 168
 169     $scope ||= \%global_names;
 170     if ( my $prev = $scope->{ $name } ) {
 171         my $name_orig = $name;
 172         $name        .= sprintf( "%02d", ++$prev );
 173         substr($name, $max_id_length - 3) = "00"
 174             if length( $name ) > $max_id_length;
 175
 176         warn "The name '$name_orig' has been changed to ",
 177              "'$name' to make it unique.\n" if $WARN;
 178
 179         $scope->{ $name_orig }++;
 180     }
 181
 182     $scope->{ $name }++;
 183     return $name;
 184 }
 185
 186 1;
 187
 188 =head1 NAME
 189
 190 SQL::Translator::Producer::SQLite - SQLite producer for SQL::Translator
 191
 192 =head1 AUTHOR
 193
 194 Ken Y. Clark E<lt>kclark@cpan.orgE<gt>