fix POD for scalarref tables

[dbsrgits/DBIx-Class-Schema-Loader.git] / lib / DBIx / Class / Schema / Loader / Base.pm

diff --git a/lib/DBIx/Class/Schema/Loader/Base.pm b/lib/DBIx/Class/Schema/Loader/Base.pm
index 6ea127f..e4b1265 100644 (file)
--- a/lib/DBIx/Class/Schema/Loader/Base.pm
+++ b/lib/DBIx/Class/Schema/Loader/Base.pm
@@ -23,6 +23,7 @@ use DBIx::Class::Schema::Loader::Optional::Dependencies ();
 use Try::Tiny;
 use DBIx::Class ();
 use Encode qw/encode/;
+use List::MoreUtils 'all';
 use namespace::clean;
 
 our $VERSION = '0.07010';
@@ -72,6 +73,7 @@ __PACKAGE__->mk_group_ro_accessors('simple', qw/
                                 qualify_objects
                                 tables
                                 class_to_table
+                                uniq_to_primary
 /);
 
 
@@ -586,6 +588,12 @@ 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 with non-nullable columns
+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
@@ -842,7 +850,7 @@ EOF
 Could not eval expression '$result_namespace' for result_namespace from
 $filename: $@
 EOF
-    $result_namespace = $ds;
+    $result_namespace = $ds || '';
 
     if ($load_classes && (not defined $self->use_namespaces)) {
         warn <<"EOF"  unless $ENV{SCHEMA_LOADER_BACKCOMPAT};
@@ -1134,8 +1142,7 @@ sub rescan {
         }
     }
 
-    delete $self->{_dump_storage};
-    delete $self->{_relations_started};
+    delete @$self{qw/_dump_storage _relations_started _uniqs_started/};
 
     my $loaded = $self->_load_tables(@current);
 
@@ -1919,8 +1926,6 @@ sub _setup_src_meta {
     # be careful to not create refs Data::Dump can "optimize"
     $full_table_name = \do {"".$full_table_name} if ref $table_name;
 
-    $self->_raw_stmt($table_class, ''); # add a blank line
-
     $self->_dbic_stmt($table_class, 'table', $full_table_name);
 
     my $cols     = $self->_table_columns($table);
@@ -1960,6 +1965,39 @@ 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];
+    }
+
+    my @non_nullable_uniqs = grep {
+        all { $col_info->{$_}{is_nullable} == 0 } @{ $_->[1] }
+    } @uniqs;
+
+    if ($self->uniq_to_primary && (not @$pks) && @non_nullable_uniqs) {
+        my @by_colnum = sort { $b->[0] <=> $a->[0] }
+            map [ scalar @{ $_->[1] }, $_ ], @non_nullable_uniqs;
+
+        if (not (@by_colnum > 1 && $by_colnum[0][0] == $by_colnum[1][0])) {
+            my @keys = map $_->[1], @by_colnum;
+
+            my $pk = $keys[0];
+
+            # remove the uniq from list
+            @uniqs = grep { $_->[0] ne $pk->[0] } @uniqs;
+
+            $pks = $pk->[1];
+        }
+    }
+
     foreach my $pkcol (@$pks) {
         $col_info->{$pkcol}{is_nullable} = 0;
     }
@@ -1970,19 +2008,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 {
@@ -2175,7 +2207,13 @@ sub _make_pod {
     my $class  = shift;
     my $method = shift;
 
-    if ( $method eq 'add_columns' ) {
+    if ($method eq 'table') {
+        my $table = $_[0];
+        $table = $$table if ref $table eq 'SCALAR';
+        $self->_pod($class, "=head1 TABLE: C<$table>");
+        $self->_pod_cut($class);
+    }
+    elsif ( $method eq 'add_columns' ) {
         $self->_pod( $class, "=head1 ACCESSORS" );
         my $col_counter = 0;
         my @cols = @_;
@@ -2208,6 +2246,35 @@ sub _make_pod {
         $self->_pod_cut( $class );
         $self->{_relations_started} { $class } = 1;
     }
+    elsif ($method eq 'add_unique_constraint') {
+        $self->_pod($class, '=head1 UNIQUE CONSTRAINTS')
+            unless $self->{_uniqs_started}{$class};
+        
+        my ($name, $cols) = @_;
+
+        $self->_pod($class, "=head2 C<$name>");
+        $self->_pod($class, '=over 4');
+        
+        foreach my $col (@$cols) {
+            $self->_pod($class, "=item \* L</$col>");
+        }
+
+        $self->_pod($class, '=back');
+        $self->_pod_cut($class);
+
+        $self->{_uniqs_started}{$class} = 1;
+    }
+    elsif ($method eq 'set_primary_key') {
+        $self->_pod($class, "=head1 PRIMARY KEY");
+        $self->_pod($class, '=over 4');
+        
+        foreach my $col (@_) {
+            $self->_pod($class, "=item \* L</$col>");
+        }
+
+        $self->_pod($class, '=back');
+        $self->_pod_cut($class);
+    }
 }
 
 sub _pod_class_list {