lib/SQL/Translator/Producer/SQLite.pm

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