added uniq_to_primary option to promote unique keys to primary keys (RT#25944)

diff --git a/Changes b/Changes
index 1771410..8b8f0f1 100644 (file)
--- a/Changes
+++ b/Changes
@@ -1,5 +1,7 @@
 Revision history for Perl extension DBIx::Class::Schema::Loader
 
+        - added uniq_to_primary option to promote unique keys to primary keys
+          (RT#25944)
         - support arrayrefs for result_namespace and resultset_namespace
           (RT#40214)
         - add naming => { monikers => 'preserve' } or 'singular'/'plural' to

diff --git a/lib/DBIx/Class/Schema/Loader/Base.pm b/lib/DBIx/Class/Schema/Loader/Base.pm
index 998d536..ba03774 100644 (file)
--- a/lib/DBIx/Class/Schema/Loader/Base.pm
+++ b/lib/DBIx/Class/Schema/Loader/Base.pm
@@ -72,6 +72,7 @@ __PACKAGE__->mk_group_ro_accessors('simple', qw/
                                 qualify_objects
                                 tables
                                 class_to_table
+                                uniq_to_primary
 /);
 
 
@@ -586,6 +587,11 @@ rather than column names/accessors.
 The default is to just append C<_rel> to the relationship name, see
 L</RELATIONSHIP NAME COLLISIONS>.
 
+=head2 uniq_to_primary
+
+Automatically promotes the largest unique constraints on tables to primary
+keys, assuming there is only one largest unique constraint.
+
 =head1 METHODS
 
 None of these methods are intended for direct invocation by regular
@@ -1957,6 +1963,30 @@ sub _setup_src_meta {
 
     my $pks = $self->_table_pk_info($table) || [];
 
+    my %uniq_tag; # used to eliminate duplicate uniqs
+
+    $uniq_tag{ join("\0", @$pks) }++ if @$pks; # pk is a uniq
+
+    my $uniqs = $self->_table_uniq_info($table) || [];
+    my @uniqs;
+
+    foreach my $uniq (@$uniqs) {
+        my ($name, $cols) = @$uniq;
+        next if $uniq_tag{ join("\0", @$cols) }++; # skip duplicates
+        push @uniqs, [$name, $cols];
+    }
+
+    if ((not @$pks) && @uniqs && $self->uniq_to_primary) {
+        my @by_colnum = sort { $b->[0] <=> $a->[0] }
+            map [ scalar @{ $_->[1] }, $_ ], @uniqs;
+
+        if (not (@by_colnum > 1 && $by_colnum[0][0] == $by_colnum[1][0])) {
+            @uniqs = map $_->[1], @by_colnum;
+
+            $pks = (shift @uniqs)->[1];
+        }
+    }
+
     foreach my $pkcol (@$pks) {
         $col_info->{$pkcol}{is_nullable} = 0;
     }
@@ -1967,19 +1997,13 @@ sub _setup_src_meta {
         map { $_, ($col_info->{$_}||{}) } @$cols
     );
 
-    my %uniq_tag; # used to eliminate duplicate uniqs
+    $self->_dbic_stmt($table_class, 'set_primary_key', @$pks)
+        if @$pks;
 
-    @$pks ? $self->_dbic_stmt($table_class,'set_primary_key',@$pks)
-          : carp("$table has no primary key");
-    $uniq_tag{ join("\0", @$pks) }++ if @$pks; # pk is a uniq
-
-    my $uniqs = $self->_table_uniq_info($table) || [];
-    for (@$uniqs) {
-        my ($name, $cols) = @$_;
-        next if $uniq_tag{ join("\0", @$cols) }++; # skip duplicates
+    foreach my $uniq (@uniqs) {
+        my ($name, $cols) = @$uniq;
         $self->_dbic_stmt($table_class,'add_unique_constraint', $name, $cols);
     }
-
 }
 
 sub __columns_info_for {

diff --git a/t/lib/dbixcsl_common_tests.pm b/t/lib/dbixcsl_common_tests.pm
index e3df577..c767ae2 100644 (file)
--- a/t/lib/dbixcsl_common_tests.pm
+++ b/t/lib/dbixcsl_common_tests.pm
@@ -120,7 +120,7 @@ sub run_tests {
     $num_rescans++ if $self->{vendor} eq 'Firebird';
 
     plan tests => @connect_info *
-        (206 + ($self->{skip_rels} ? 5 : $num_rescans * $col_accessor_map_tests) + $extra_count + ($self->{data_type_tests}{test_count} || 0));
+        (207 + ($self->{skip_rels} ? 5 : $num_rescans * $col_accessor_map_tests) + $extra_count + ($self->{data_type_tests}{test_count} || 0));
 
     foreach my $info_idx (0..$#connect_info) {
         my $info = $connect_info[$info_idx];
@@ -244,6 +244,7 @@ sub setup_schema {
         rel_collision_map       => { '^(set_primary_key)\z' => 'caught_rel_collision_%s' },
         col_accessor_map        => \&test_col_accessor_map,
         result_components_map   => { LoaderTest2X => 'TestComponentForMap', LoaderTest1 => '+TestComponentForMapFQN' },
+        uniq_to_primary         => 1,
         %{ $self->{loader_options} || {} },
     );
 
@@ -270,7 +271,7 @@ sub setup_schema {
         my $standard_sources = not defined $expected_count;
 
         if ($standard_sources) {
-            $expected_count = 36;
+            $expected_count = 37;
 
             if (not ($self->{vendor} eq 'mssql' && $connect_info->[0] =~ /Sybase/)) {
                 $expected_count++ for @{ $self->{data_type_tests}{table_names} || [] };
@@ -307,29 +308,8 @@ sub setup_schema {
 
         $warn_count-- for grep { my $w = $_; grep $w =~ $_, @{ $self->{failtrigger_warnings} || [] } } @loader_warnings;
 
-        if ($standard_sources) {
-            if($self->{skip_rels}) {
-                SKIP: {
-                    is(scalar(@loader_warnings), $warn_count, "No loader warnings")
-                        or diag @loader_warnings;
-                    skip "No missing PK warnings without rels", 1;
-                }
-            }
-            else {
-                $warn_count++;
-                is(scalar(@loader_warnings), $warn_count, "Expected loader warnings")
-                    or diag @loader_warnings;
-                is(grep(/loader_test9 has no primary key/i, @loader_warnings), 1,
-                     "Missing PK warning");
-            }
-        }
-        else {
-            SKIP: {
-                is scalar(@loader_warnings), $warn_count, 'Correct number of warnings'
-                    or diag @loader_warnings;
-                skip "not testing standard sources", 1;
-            }
-        }
+        is scalar(@loader_warnings), $warn_count, 'Correct number of warnings'
+            or diag @loader_warnings;
     }
 
     exit if ($file_count||0) != $expected_count;
@@ -369,11 +349,16 @@ sub test_schema {
     my $class35   = $classes->{loader_test35};
     my $rsobj35   = $conn->resultset($moniker35);
 
+    my $moniker50 = $monikers->{loader_test50};
+    my $class50   = $classes->{loader_test50};
+    my $rsobj50   = $conn->resultset($moniker50);
+
     isa_ok( $rsobj1, "DBIx::Class::ResultSet" );
     isa_ok( $rsobj2, "DBIx::Class::ResultSet" );
     isa_ok( $rsobj23, "DBIx::Class::ResultSet" );
     isa_ok( $rsobj24, "DBIx::Class::ResultSet" );
     isa_ok( $rsobj35, "DBIx::Class::ResultSet" );
+    isa_ok( $rsobj50, "DBIx::Class::ResultSet" );
 
     # check result_namespace
     my @schema_dir = split /::/, SCHEMA_CLASS;
@@ -471,6 +456,11 @@ sub test_schema {
     }
     ok($uniq2_test, "Multi-col unique constraint");
 
+    my %uniq3 = $class50->unique_constraints;
+
+    is_deeply $uniq3{primary}, ['id1', 'id2'],
+        'unique constraint promoted to primary key with uniq_to_primary';
+
     is($moniker2, 'LoaderTest2X', "moniker_map testing");
 
     SKIP: {
@@ -1438,6 +1428,14 @@ sub create {
                 c_char_as_data VARCHAR(100)
             ) $self->{innodb}
         },
+        qq{
+            CREATE TABLE loader_test50 (
+                id INTEGER NOT NULL UNIQUE,
+                id1 INTEGER NOT NULL,
+                id2 INTEGER NOT NULL,
+                UNIQUE (id1, id2)
+            ) $self->{innodb}
+        },
     );
 
     # some DBs require mixed case identifiers to be quoted