lib/SQL/Translator/Producer/SQLite.pm

   1 package SQL::Translator::Producer::SQLite;
   2
   3 # -------------------------------------------------------------------
   4 # $Id: SQLite.pm,v 1.2 2003-03-12 14:17:11 dlc 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::Utils qw(debug);
  28
  29 use vars qw[ $VERSION $DEBUG $WARN ];
  30 $VERSION = sprintf "%d.%02d", q$Revision: 1.2 $ =~ /(\d+)\.(\d+)/;
  31
  32 my %used_identifiers = ();
  33 my $max_id_length    = 30;
  34 my %global_names;
  35 my %truncated;
  36
  37 sub import {
  38     warn "loading " . __PACKAGE__ . "...\n";
  39 }
  40
  41 sub produce {
  42     my ($translator, $data) = @_;
  43     $DEBUG                  = $translator->debug;
  44     $WARN                   = $translator->show_warnings;
  45     my $no_comments         = $translator->no_comments;
  46     my $add_drop_table      = $translator->add_drop_table;
  47
  48     debug("PKG: Beginning production\n");
  49
  50     my $create;
  51     unless ( $no_comments ) {
  52         $create .= sprintf "--\n-- Created by %s\n-- Created on %s\n--\n\n",
  53             __PACKAGE__, scalar localtime;
  54     }
  55
  56     for my $table ( keys %{ $data } ) {
  57         debug("PKG: Looking at table '$table'\n");
  58         my $table_data = $data->{$table};
  59         my @fields = sort {
  60             $table_data->{'fields'}->{$a}->{'order'}
  61             <=>
  62             $table_data->{'fields'}->{$b}->{'order'}
  63         } keys %{$table_data->{'fields'}};
  64
  65         #
  66         # Header.  Should this look like what mysqldump produces?
  67         #
  68         $create .= "--\n-- Table: $table\n--\n" unless $no_comments;
  69         $create .= qq[DROP TABLE $table;\n] if $add_drop_table;
  70         $create .= "CREATE TABLE $table (";
  71
  72         #
  73         # Fields
  74         #
  75         for (my $i = 0; $i <= $#fields; $i++) {
  76             my $field = $fields[$i];
  77             debug("PKG: Looking at field '$field'\n");
  78             my $field_data = $table_data->{'fields'}->{$field};
  79             my @fdata = ("", $field);
  80             $create .= "\n";
  81
  82             # data type and size
  83             my $data_type = lc $field_data->{'data_type'};
  84             my $list      = $field_data->{'list'} || [];
  85             my $commalist = join ",", @$list;
  86             my $size;
  87
  88             if ( $data_type eq 'set' ) {
  89                 $data_type = 'varchar';
  90                 $size      = length $commalist;
  91             }
  92             else {
  93                 $size = join( ', ', @{ $field_data->{'size'} || [] } );
  94             }
  95
  96             push @fdata, sprintf "%s%s", $data_type, ($size) ? "($size)" : '';
  97
  98             # MySQL qualifiers
  99 #            for my $qual ( qw[ binary unsigned zerofill ] ) {
 100 #                push @fdata, $qual
 101 #                    if $field_data->{ $qual } ||
 102 #                       $field_data->{ uc $qual };
 103 #            }
 104
 105             # Null?
 106             push @fdata, "NOT NULL" unless $field_data->{'null'};
 107
 108             # Default?  XXX Need better quoting!
 109             my $default = $field_data->{'default'};
 110             if ( defined $default ) {
 111                 if ( uc $default eq 'NULL') {
 112                     push @fdata, "DEFAULT NULL";
 113                 } else {
 114                     push @fdata, "DEFAULT '$default'";
 115                 }
 116             }
 117
 118             # auto_increment?
 119 #            push @fdata, "auto_increment" if $field_data->{'is_auto_inc'};
 120
 121             # primary key?
 122             # This is taken care of in the indices, could be duplicated here
 123             # push @fdata, "PRIMARY KEY" if $field_data->{'is_primary_key'};
 124
 125
 126             $create .= (join " ", '', @fdata);
 127             $create .= "," unless ($i == $#fields);
 128         }
 129         #
 130         # Indices
 131         #
 132         my @index_creates;
 133         my $idx_name_default;
 134         for my $index ( @{ $table_data->{'indices'} || [] } ) {
 135             my ($name, $type, $fields) = @{ $index }{ qw[ name type fields ] };
 136             $name ||= '';
 137             my $index_type =
 138                 $type eq 'primary_key' ? 'PRIMARY KEY' :
 139                 $type eq 'unique'      ? 'UNIQUE INDEX'  : 'INDEX';
 140             if ( $type eq 'primary_key' ) {
 141                 $create .= join(",\n", '',
 142                     "  $index_type $name (" . join( ', ', @$fields ) . ')'
 143                 );
 144             }
 145             else {
 146                 $name = mk_name(
 147                     $table, $name || ++$idx_name_default
 148                 );
 149                 push @index_creates,
 150                     "CREATE $index_type $name on $table ".
 151                     '(' . join( ', ', @$fields ) . ')';
 152             }
 153         }
 154
 155         $create .= "\n);\n";
 156
 157         for my $index_create ( @index_creates ) {
 158             $create .= "$index_create;\n";
 159         }
 160
 161         $create .= "\n";
 162     }
 163
 164     return $create;
 165 }
 166
 167
 168 # -------------------------------------------------------------------
 169 sub mk_name {
 170     my ($basename, $type, $scope, $critical) = @_;
 171     my $basename_orig = $basename;
 172     my $max_name      = $type
 173                         ? $max_id_length - (length($type) + 1)
 174                         : $max_id_length;
 175     $basename         = substr( $basename, 0, $max_name )
 176                         if length( $basename ) > $max_name;
 177     my $name          = $type ? "${type}_$basename" : $basename;
 178
 179     if ( $basename ne $basename_orig and $critical ) {
 180         my $show_type = $type ? "+'$type'" : "";
 181         warn "Truncating '$basename_orig'$show_type to $max_id_length ",
 182             "character limit to make '$name'\n" if $WARN;
 183         $truncated{ $basename_orig } = $name;
 184     }
 185
 186     $scope ||= \%global_names;
 187     if ( my $prev = $scope->{ $name } ) {
 188         my $name_orig = $name;
 189         $name        .= sprintf( "%02d", ++$prev );
 190         substr($name, $max_id_length - 3) = "00"
 191             if length( $name ) > $max_id_length;
 192
 193         warn "The name '$name_orig' has been changed to ",
 194              "'$name' to make it unique.\n" if $WARN;
 195
 196         $scope->{ $name_orig }++;
 197     }
 198
 199     $scope->{ $name }++;
 200     return $name;
 201 }
 202
 203 1;
 204 __END__
 205
 206 =head1 NAME
 207
 208 SQL::Translator::Producer::SQLite - SQLite-specific producer for SQL::Translator
 209
 210 =head1 AUTHOR
 211
 212 Ken Y. Clark E<lt>kclark@cpan.orgE<gt>