Add index length option for MySQL

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,7 +693,7 @@ sub create_index
                 $options->{max_id_length} || $DEFAULT_MAX_ID_LENGTH
           ))
         : '',
-        '(' . join( ', ', map { $generator->quote($_) } $index->fields ) . ')'
+        '(' . join( ', ', @fields) . ')'
     );
 }
 

lib/SQL/Translator/Producer/YAML.pm

@@ -173,7 +173,8 @@ sub view_index {
     return {
         'name'      => scalar $index->name,
         'type'      => scalar $index->type,
-        'fields'    => [ map { ref($_) ? $_->name : $_ } $index->fields ],
+        # If the index has extra properties, make sure these are written too
+        'fields'    => [ map { ref($_) && $_->extra && %{$_->extra} ? { name => $_->name, %{$_->extra} } : "$_" } $index->fields ],
         'options'   => scalar $index->options,
         keys %{$index->extra} ? ('extra' => { $index->extra } ) : (),
     };

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,12 +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;
 
 =cut
 
-with ListAttr fields => ( uniq => 1 );
+
+with ListAttr fields => (
+  coerce => sub {
+    my %seen;
+    return [
+      grep !$seen{$_->name}++,
+      map SQL::Translator::Schema::IndexField->new($_),
+      @{parse_list_arg($_[0])}
+    ]
+  }
+);
 
 sub is_valid {
 
@@ -174,27 +186,23 @@ around equals => sub {
     return 0 unless $self->$orig($other);
 
     unless ($ignore_index_names) {
-      unless ((!$self->name && ($other->name eq $other->fields->[0])) ||
-        (!$other->name && ($self->name eq $self->fields->[0]))) {
+      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) {
-      $otherField = uc($otherField) if $case_insensitive;
-      $otherFields{$otherField} = 1;
-    }
-    foreach my $selfField ($self->fields) { # check for self fields in hash
-      $selfField = uc($selfField) if $case_insensitive;
-      return 0 unless $otherFields{$selfField};
-      delete $otherFields{$selfField};
+    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>[email protected]<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';
 
@@ -131,7 +132,7 @@ sub parse_list_arg {
     #
     # This protects stringification of references.
     #
-    if ( @$list && ref $list->[0] ) {
+    if (any { ref $_ } @$list ) {
         return $list;
     }
     #

t/13schema.t

@@ -248,10 +248,45 @@ require_ok( 'SQL::Translator::Schema' );
     isa_ok( $index2, 'SQL::Translator::Schema::Index', 'Index' );
     is( $index2->name, 'bar', 'Index name is "bar"' );
 
+    my $index3 = $person_table->add_index( name => "sized", fields => [ { name => 'forename', prefix_length => 15} ] )
+        or warn $person_table->error;
+    isa_ok( $index3, 'SQL::Translator::Schema::Index', 'Index' );
+    is( $index3->name, 'sized', 'Index name is "sized"' );
+
+    # Test index comparison function.
+    # 2 completely different indexes
+    ok( !$index3->equals($index2), "2 different indexes return false on equals() function (simple)" );
+
+    # Same indexes with different lengths
+    my $index4 = SQL::Translator::Schema::Index->new(
+        name => "sized", fields => [ { name => 'forename', prefix_length => 20} ]
+    );
+    ok( !$index3->equals($index4), "2 different indexes return false on equals() function (index length different)" );
+
+    # Identical indexes with lengths
+    my $index5 = SQL::Translator::Schema::Index->new(
+        name => "sized", fields => [ { name => 'forename', prefix_length => 15} ]
+    );
+    ok( $index3->equals($index5), "2 identical indexes return true on equals() (with index length)" );
+
+    # Identical indexes without lengths
+    my $index6 = SQL::Translator::Schema::Index->new( name => "foo", fields => [qw/foo age/] );
+    ok( $index6->equals($index1), "2 identical indexes return true on equals() (without index length)" );
+
+    # Check comparison of index names
+    my $index7 = SQL::Translator::Schema::Index->new( name => "bar" );
+    ok( $index7->equals($index2), "2 empty indexes return true on equals()" );
+
+    # Check that 2 indexes are equal, if one doesn't have a name, and the
+    # other has a name that is the same as the first field
+    my $index8 = SQL::Translator::Schema::Index->new( fields => [qw/foo age/] );
+    ok( $index8->equals($index6, 0, 0, 1), "Compare 2 indexes, one without name" );
+
     my $indices = $person_table->get_indices;
-    is( scalar @$indices, 2, 'Two indices' );
+    is( scalar @$indices, 3, 'Two indices' );
     is( $indices->[0]->name, 'foo', '"foo" index' );
     is( $indices->[1]->name, 'bar', '"bar" index' );
+    is( $indices->[2]->name, 'sized', '"sized" index' );
 
     #
     # $table-> drop_index

t/38-mysql-producer.t

@@ -19,7 +19,7 @@ use FindBin qw/$Bin/;
 #=============================================================================
 
 BEGIN {
-    maybe_plan(75,
+    maybe_plan(79,
         'YAML',
         'SQL::Translator::Producer::MySQL',
         'Test::Differences',
@@ -782,6 +782,38 @@ EOV
     }
 }
 
+{
+    my $table = SQL::Translator::Schema::Table->new( name => 'foobar', fields => ['foo'] );
+
+    {
+        my $index = $table->add_index(name => 'myindex', fields => ['foo']);
+        my ($def) = SQL::Translator::Producer::MySQL::create_index($index);
+        is($def, 'INDEX myindex (foo)', 'index created');
+    }
+
+    {
+        my $index = $table->add_index(fields => ['foo']);
+        my ($def) = SQL::Translator::Producer::MySQL::create_index($index);
+        is($def, 'INDEX (foo)', 'index created');
+    }
+
+    {
+        my $index = $table->add_index(fields => [ { name => 'foo', prefix_length => 25 } ], type => 'unique');
+        my ($def) = SQL::Translator::Producer::MySQL::create_index($index);
+        is($def, 'UNIQUE INDEX (foo(25))', 'unique index created');
+    }
+
+    {
+        my $index = $table->add_index(name => 'sized', fields => [
+            'foobar',
+            { name => 'foo', prefix_length => 10 },
+            { name => 'bar', prefix_length => 15 },
+        ]);
+        my ($def) = SQL::Translator::Producer::MySQL::create_index($index);
+        is($def, 'INDEX sized (foobar, foo(10), bar(15))', 'index created');
+    }
+}
+
 { # test for rt62250
     my $table = SQL::Translator::Schema::Table->new(name => 'table');
     $table->add_field(

t/45db2-producer.t

@@ -14,7 +14,7 @@ use FindBin qw/$Bin/;
 #=============================================================================
 
 BEGIN {
-    maybe_plan(4,
+    maybe_plan(6,
         'SQL::Translator::Producer::DB2',
         'Test::Differences',
     )
@@ -58,5 +58,13 @@ my $add_field = SQL::Translator::Producer::DB2::add_field($field1);
 
 is($add_field, 'ALTER TABLE mytable ADD COLUMN myfield VARCHAR(10)', 'Add field works');
 
+my $index = $table->add_index(name => 'myindex', fields => ['foo']);
+my ($def) = SQL::Translator::Producer::DB2::create_index($index);
+is($def, 'CREATE INDEX myindex ON mytable ( foo );', 'index created');
+
+my $index2 = $table->add_index(name => 'myindex', fields => [ { name => 'foo', prefix_length => 15 } ]);
+my ($def2) = SQL::Translator::Producer::DB2::create_index($index);
+is($def2, 'CREATE INDEX myindex ON mytable ( foo );', 'index created');
+
 my $drop_field = SQL::Translator::Producer::DB2::drop_field($field2);
 is($drop_field, '', 'Drop field works');

t/47postgres-producer.t

@@ -648,6 +648,14 @@ is($view2_sql1, $view2_sql_replace, 'correct "CREATE OR REPLACE VIEW" SQL 2');
         is($def, 'CREATE INDEX "myindex" on "foobar" ("foo")', 'index created w/ quotes');
     }
 
+    {
+        my $index = $table->add_index(name => 'myindex', fields => [ { name => 'foo', prefix_length => 20 } ]);
+        my ($def) = SQL::Translator::Producer::PostgreSQL::create_index($index);
+        is($def, "CREATE INDEX myindex on foobar (foo)", 'index created');
+        ($def) = SQL::Translator::Producer::PostgreSQL::create_index($index, $quote);
+        is($def, 'CREATE INDEX "myindex" on "foobar" ("foo")', 'index created w/ quotes');
+    }
+
     {
         my $index = $table->add_index(name => 'myindex', fields => ['lower(foo)']);
         my ($def) = SQL::Translator::Producer::PostgreSQL::create_index($index);

t/55-oracle-producer.t

@@ -69,6 +69,9 @@ use SQL::Translator::Producer::Oracle;
         type             => FOREIGN_KEY,
     );
 
+    my $index1 = $table1->add_index(name => 'myfooindex', fields => ['foo']);
+    my $index2 = $table1->add_index(name => 'mybarindex', fields => [ { name => 'bar', prefix_length => 10 } ]);
+
     my ($table1_def, $fk1_def, $trigger1_def,
         $index1_def, $constraint1_def
     ) = SQL::Translator::Producer::Oracle::create_table($table1);
@@ -80,6 +83,14 @@ use SQL::Translator::Producer::Oracle;
         'correct "CREATE CONSTRAINT" SQL'
     );
 
+    is_deeply(
+        $index1_def,
+        [   'CREATE INDEX myfooindex ON table1 (foo)',
+            'CREATE INDEX mybarindex ON table1 (bar)'
+        ],
+        'correct "CREATE INDEX" SQL'
+    );
+
     my $materialized_view = SQL::Translator::Schema::View->new(
         name    => 'matview',
         sql     => 'SELECT id, name FROM table3',

t/56-sqlite-producer.t

@@ -193,6 +193,12 @@ $SQL::Translator::Producer::SQLite::NO_QUOTES = 0;
         is($def, 'CREATE INDEX "myindex" ON "foobar" ("foo")', 'index created');
     }
 
+    {
+        my $index = $table->add_index(name => 'myindex2', fields => [ { name => 'foo', prefix_length => 15 } ]);
+        my ($def) = SQL::Translator::Producer::SQLite::create_index($index);
+        is($def, 'CREATE INDEX "myindex2" ON "foobar" ("foo")', 'index created');
+    }
+
     {
         my $index = $table->add_index(fields => ['foo']);
         my ($def) = SQL::Translator::Producer::SQLite::create_index($index);