Add index length option for MySQL

lib/SQL/Translator/Generator/DDL/SQLServer.pm

@@ -67,7 +67,7 @@ sub index {
   'CREATE INDEX ' .
    $_[0]->quote($_[1]->name || $_[1]->table->name . '_idx') .
    ' ON ' . $_[0]->quote($_[1]->table->name) .
-   ' (' . join( ', ', map $_[0]->quote($_), $_[1]->field_names ) . ');'
+   ' (' . join( ', ', map $_[0]->quote($_), $_[1]->fields ) . ');'
 }
 
 sub unique_constraint_single {

lib/SQL/Translator/Producer/DB2.pm

@@ -310,7 +310,7 @@ sub create_index
                       $index->type() =~ /^UNIQUE$/i ? 'UNIQUE' : '',
                       $index->name,
                       $index->table->name,
-                      join(', ', $index->field_names) );
+                      join(', ', $index->fields) );
 
     return $out;
 }

lib/SQL/Translator/Producer/GraphViz.pm

@@ -465,7 +465,7 @@ sub produce {
                 ? $index->name . ':'
                 : ()
               ,
-              join (', ', $index->field_names_with_lengths),
+              join (', ', $index->fields),
               ($index->type eq 'UNIQUE') ? '[U]' : (),
             );
            }

lib/SQL/Translator/Producer/HTML.pm

@@ -181,7 +181,7 @@ sub produce {
 
             for my $index ( @indices ) {
                 my $name   = $index->name || '';
-                my $fields = join( ', ', $index->field_names_with_lengths ) || '';
+                my $fields = join( ', ', $index->fields ) || '';
 
                 push @html,
                     $q->Tr({ -class => 'IndexCell' },

lib/SQL/Translator/Producer/MySQL.pm

@@ -674,6 +674,15 @@ sub create_index
     my ( $index, $options ) = @_;
     my $generator = _generator($options);
 
+    my @fields;
+    for my $field ($index->fields) {
+      my $name = $generator->quote($field->name);
+      if (my $len = $field->extra->{prefix_length}) {
+        $name .= "($len)";
+      }
+      push @fields, $name;
+
+    }
     return join(
         ' ',
         map { $_ || () }
@@ -684,9 +693,7 @@ sub create_index
                 $options->{max_id_length} || $DEFAULT_MAX_ID_LENGTH
           ))
         : '',
-        '(' . join( ', ', map {
-            ref $_ && exists $_->{prefix_length} ? $generator->quote($_->{name}) . "($_->{prefix_length})" : $generator->quote($_)
-        } $index->fields ) . ')'
+        '(' . join( ', ', @fields) . ')'
     );
 }
 

lib/SQL/Translator/Producer/Oracle.pm

@@ -329,7 +329,7 @@ sub create_table {
     for my $index ( $table->get_indices ) {
         my $index_name = $index->name || '';
         my $index_type = $index->type || NORMAL;
-        my @fields     = map { quote($_, $qf) } $index->field_names;
+        my @fields     = map { quote($_, $qf) } $index->fields;
         next unless @fields;
         debug("ORA: Creating $index_type index on fields (" . join(', ', @fields) . ") named $index_name");
         my @index_options;
@@ -677,7 +677,7 @@ sub create_index {
         $index_name ? quote($index_name, $qf): '',
         'ON',
         quote($index->table, $qt),
-        '(' . join( ', ', map { quote($_, $qf) } $index->field_names ) . ")$index_options"
+        '(' . join( ', ', map { quote($_, $qf) } $index->fields ) . ")$index_options"
     );
 }
 

lib/SQL/Translator/Producer/POD.pm

@@ -71,7 +71,7 @@ sub produce {
             for my $index ( @indices ) {
                 $pod .= "=head4 " . $index->type . "\n\n=over 4\n\n";
                 $pod .= "=item * Fields = " .
-                    join(', ', $index->field_names_with_lengths ) . "\n\n";
+                    join(', ', $index->fields ) . "\n\n";
                 $pod .= "=back\n\n";
             }
         }

lib/SQL/Translator/Producer/PostgreSQL.pm

@@ -619,7 +619,7 @@ sub create_geometry_constraints {
             || join('_', $table_name, 'idx', ++$index_name{ $table_name });
 
         my $type = $index->type || NORMAL;
-        my @fields     =  $index->field_names;
+        my @fields     =  $index->fields;
         return unless @fields;
 
         my %index_extras;

lib/SQL/Translator/Producer/SQLite.pm

@@ -299,7 +299,7 @@ sub create_index
     my $type   = $index->type eq 'UNIQUE' ? "UNIQUE " : '';
 
     # strip any field size qualifiers as SQLite doesn't like these
-    my @fields = map { s/\(\d+\)$//; _generator()->quote($_) } $index->field_names;
+    my @fields = map { s/\(\d+\)$//; _generator()->quote($_) } $index->fields;
     $index_table_name = _generator()->quote($index_table_name);
     warn "removing schema name from '" . $index->table->name . "' to make '$index_table_name'\n" if $WARN;
     my $index_def =

lib/SQL/Translator/Producer/Sybase.pm

@@ -286,7 +286,7 @@ sub produce {
             push @index_defs,
                 'CREATE INDEX ' . $index->name .
                 " ON $table_name (".
-                join( ', ',$index->field_names ) . ")";
+                join( ', ', $index->fields ) . ")";
         }
 
         my $drop_statement = $add_drop_table

lib/SQL/Translator/Producer/YAML.pm

@@ -173,7 +173,7 @@ sub view_index {
     return {
         'name'      => scalar $index->name,
         'type'      => scalar $index->type,
-        'fields'    => [ $index->fields ],
+        'fields'    => [ map { ref($_) ? $_->name : $_ } $index->fields ],
         'options'   => scalar $index->options,
         keys %{$index->extra} ? ('extra' => { $index->extra } ) : (),
     };

lib/SQL/Translator/Role/ListAttr.pm

@@ -22,7 +22,7 @@ attributes.
 
 =cut
 
-use SQL::Translator::Utils qw(parse_list_arg ex2err uniq uniq_keys);
+use SQL::Translator::Utils qw(parse_list_arg ex2err uniq);
 use Sub::Quote qw(quote_sub);
 
 use Package::Variant (
@@ -83,11 +83,8 @@ sub make_variant {
     my $may_throw = delete $arguments{may_throw};
     my $undef_if_empty = delete $arguments{undef_if_empty};
     my $append = delete $arguments{append};
-    my $uniq_keys = delete $arguments{uniq_keys};
     my $coerce = delete $arguments{uniq}
         ? sub { [ uniq @{parse_list_arg($_[0])} ] }
-        : $uniq_keys
-        ? sub { [ uniq_keys $uniq_keys, @{parse_list_arg($_[0])} ] }
         : \&parse_list_arg;
 
     has($name => (

lib/SQL/Translator/Schema/Index.pm

@@ -27,7 +27,8 @@ Primary and unique keys are table constraints, not indices.
 
 use Moo;
 use SQL::Translator::Schema::Constants;
-use SQL::Translator::Utils qw(ex2err throw);
+use SQL::Translator::Schema::IndexField;
+use SQL::Translator::Utils qw(ex2err throw parse_list_arg);
 use SQL::Translator::Role::ListAttr;
 use SQL::Translator::Types qw(schema_obj enum);
 use Sub::Quote qw(quote_sub);
@@ -61,17 +62,23 @@ names and keep them in order by the first occurrence of a field name.
   $index->fields( 'id, name' );
   $index->fields( [ 'id', 'name' ] );
   $index->fields( qw[ id name ] );
+  $index->fields(id => { name => 'name', order_by => 'ASC NULLS LAST' });
 
   my @fields = $index->fields;
 
-The length of an index can be specified as follows (only has any effect
-with a MySQL database):
-
-  $index->fields( 'id', { name => 'firstname', prefix_length => 15 } );
-
 =cut
 
-with ListAttr fields => ( uniq_keys => 'name' );
+
+with ListAttr fields => (
+  coerce => sub {
+    my %seen;
+    return [
+      grep !$seen{$_->name}++,
+      map SQL::Translator::Schema::IndexField->new($_),
+      @{parse_list_arg($_[0])}
+    ]
+  }
+);
 
 sub is_valid {
 
@@ -112,33 +119,6 @@ has name => (
     default => quote_sub(q{ '' }),
 );
 
-=head2 field_names
-
-Return just the index field names for the case when we don't care whether
-the "prefix_length" is specified or not.
-
-=cut
-
-sub field_names {
-    my ($self) = @_;
-
-    return ( map { ref $_ ? $_->{name} : $_ } ($self->fields) );
-}
-
-=head2 fields_with_lengths
-
-Return the index field names with the prefix_length appended if set.
-
-=cut
-
-sub fields_with_lengths {
-    my ($self) = @_;
-
-    print STDERR Data::Dumper::Dumper($self->fields);
-    return ( map { ref $_ ? "$_->{name}($_->{prefix_length})" : $_ }
-        ($self->fields) );
-}
-
 =head2 options
 
 Get or set the index's options (e.g., "using" or "where" for PG).  Returns
@@ -206,31 +186,23 @@ around equals => sub {
     return 0 unless $self->$orig($other);
 
     unless ($ignore_index_names) {
-      my $self_first = ref $self->fields->[0] ? $self->fields->[0]->{name} : $self->fields->[0] || '';
-      my $other_first = ref $other->fields->[0] ? $other->fields->[0]->{name} : $other->fields->[0] || '';
-      unless ((!$self->name && ($other->name eq $other_first)) ||
-        (!$other->name && ($self->name eq $self_first))) {
+      unless ((!$self->name && ($other->name eq $other->fields->[0]->name)) ||
+        (!$other->name && ($self->name eq $self->fields->[0]->name))) {
         return 0 unless $case_insensitive ? uc($self->name) eq uc($other->name) : $self->name eq $other->name;
       }
     }
     #return 0 unless $self->is_valid eq $other->is_valid;
     return 0 unless $self->type eq $other->type;
 
     # Check fields, regardless of order
-    my %otherFields = ();  # create a hash of the other fields
-    foreach my $otherField ($other->fields) {
-      my $name = ref $otherField ? $otherField->{name} : $otherField;
-      $name = uc($name) if $case_insensitive;
-      $otherFields{$name} = ref $otherField ? $otherField->{prefix_length} : -1; # -1 == no length. Easier comparison.
-    }
-    foreach my $selfField ($self->fields) { # check for self fields in hash
-      my ($name, $size) = ref $selfField ? ($selfField->{name}, $selfField->{prefix_length}) : ($selfField, -1);
-      $name = uc($name) if $case_insensitive;
-      return 0 unless exists $otherFields{$name} && $otherFields{$name} == $size;
-      delete $otherFields{$name};
+    my $get_name = sub { return $case_insensitive ? uc(shift->name) : shift->name; };
+    my @otherFields = sort { $a->{key} cmp $b->{key} } map +{ item => $_, key => $get_name->($_) }, $other->fields;
+    my @selfFields  = sort { $a->{key} cmp $b->{key} } map +{ item => $_, key => $get_name->($_) }, $self->fields;
+    return 0 unless @otherFields == @selfFields;
+    for my $idx (0..$#selfFields) {
+      return 0 unless $selfFields[$idx]{key} eq $otherFields[$idx]{key};
+      return 0 unless $self->_compare_objects(scalar $selfFields[$idx]{item}->extra, scalar $otherFields[$idx]{item}->extra);
     }
-    # Check all other fields were accounted for
-    return 0 unless keys %otherFields == 0;
 
     return 0 unless $self->_compare_objects(scalar $self->options, scalar $other->options);
     return 0 unless $self->_compare_objects(scalar $self->extra, scalar $other->extra);

lib/SQL/Translator/Schema/IndexField.pm

@@ -0,0 +1,92 @@
+package SQL::Translator::Schema::IndexField;
+
+=pod
+
+=head1 NAME
+
+SQL::Translator::Schema::IndexField - SQL::Translator index field object
+
+=head1 DESCRIPTION
+
+C<SQL::Translator::Schema::IndexField> is the index field object.
+
+Different databases allow for different options on index fields. Those are supported through here
+
+=head1 METHODS
+
+=cut 
+use Moo;
+
+extends 'SQL::Translator::Schema::Object';
+
+use overload '""' => sub { shift->name };
+
+=head2 new
+
+Object constructor.
+
+  my $schema = SQL::Translator::Schema::IndexField->new;
+
+=head2 name
+
+The name of the index. The object stringifies to this. In addition, you can simply pass
+a string to the constructor to only set this attribute.
+
+=head2 extra
+
+All options for the field are stored under the extra hash. The constructor will collect
+them for you if passed in straight. In addition, an accessor is provided for all supported options
+
+Currently supported options:
+
+=over 4
+
+=item prefix_length
+
+Supported by MySQL. Indicates that only N characters of the column are indexed.
+
+=back
+
+=cut
+
+around BUILDARGS => sub {
+  my ($orig, $self, @args) = @_;
+  if (@args == 1 && !ref $args[0]) {
+    @args = (name => $args[0]);
+  }
+  # there are some weird pathological cases where we get an object passed in rather than a
+  # hashref. We'll just clone it
+  if (ref $args[0] eq $self) {
+    return { %{$args[0]} }
+  }
+  my $args = $self->$orig(@args);
+  my $extra = delete $args->{extra} || {};
+  my $name = delete $args->{name};
+  return {
+    name => $name,
+    extra => {
+      %$extra,
+      %$args
+    }
+  }
+};
+
+has name => (
+  is => 'rw',
+  required => 1,
+);
+
+has extra => (
+  is => 'rw',
+  default => sub { {} },
+);
+
+=pod
+
+=head1 AUTHOR
+
+Veesh Goldman E<lt>veesh@cpan.orgE<gt>.
+
+=cut
+
+9007

lib/SQL/Translator/Utils.pm

@@ -7,6 +7,7 @@ use File::Spec;
 use Scalar::Util qw(blessed);
 use Try::Tiny;
 use Carp qw(carp croak);
+use List::Util qw(any);
 
 our $VERSION = '1.63';
 
@@ -15,7 +16,7 @@ our @EXPORT_OK = qw(
     debug normalize_name header_comment parse_list_arg truncate_id_uniquely
     $DEFAULT_COMMENT parse_mysql_version parse_dbms_version
     ddl_parser_instance batch_alter_table_statements
-    uniq uniq_keys throw ex2err carp_ro
+    uniq throw ex2err carp_ro
     normalize_quote_options
 );
 use constant COLLISION_TAG_LENGTH => 8;
@@ -131,7 +132,7 @@ sub parse_list_arg {
     #
     # This protects stringification of references.
     #
-    if ( @$list && grep { ref $_ } @$list ) {
+    if (any { ref $_ } @$list ) {
         return $list;
     }
     #
@@ -376,15 +377,6 @@ sub uniq {
   ) } @_;
 }
 
-sub uniq_keys {
-  my $key = shift;
-  my %seen;
-  grep {
-    my $name = ref $_ ? $_->{$key} : $_;
-    not ( $seen{$name}++ );
-  } @_;
-}
-
 sub throw {
     die SQL::Translator::Utils::Error->new($_[0]);
 }