lib/SQL/Translator/Producer/SQLite.pm

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