fix case issues for MSSQL

[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 e715268..e0a42fa 100644 (file)
--- a/lib/DBIx/Class/Schema/Loader/Base.pm
+++ b/lib/DBIx/Class/Schema/Loader/Base.pm
@@ -3,6 +3,7 @@ package DBIx::Class::Schema::Loader::Base;
 use strict;
 use warnings;
 use base qw/Class::Accessor::Grouped Class::C3::Componentised/;
+use namespace::autoclean;
 use Class::C3;
 use Carp::Clan qw/^DBIx::Class/;
 use DBIx::Class::Schema::Loader::RelBuilder;
@@ -15,6 +16,9 @@ use Lingua::EN::Inflect::Number qw//;
 use File::Temp qw//;
 use Class::Unload;
 use Class::Inspector ();
+use Data::Dumper::Concise;
+use Scalar::Util 'looks_like_number';
+use File::Slurp 'slurp';
 require DBIx::Class;
 
 our $VERSION = '0.05003';
@@ -57,6 +61,7 @@ __PACKAGE__->mk_group_ro_accessors('simple', qw/
                                 naming
                                 datetime_timezone
                                 datetime_locale
+                                config_file
 /);
 
 
@@ -414,6 +419,11 @@ columns with the DATE/DATETIME/TIMESTAMP data_types.
 Sets the locale attribute for L<DBIx::Class::InflateColumn::DateTime> for all
 columns with the DATE/DATETIME/TIMESTAMP data_types.
 
+=head1 config_file
+
+File in Perl format, which should return a HASH reference, from which to read
+loader options.
+
 =head1 METHODS
 
 None of these methods are intended for direct invocation by regular
@@ -422,9 +432,9 @@ L<DBIx::Class::Schema::Loader>.
 
 =cut
 
-use constant CURRENT_V  => 'v5';
+my $CURRENT_V = 'v5';
 
-use constant CLASS_ARGS => qw(
+my @CLASS_ARGS = qw(
     schema_base_class result_base_class additional_base_classes
     left_base_classes additional_classes components resultset_components
 );
@@ -455,6 +465,18 @@ sub new {
 
     bless $self => $class;
 
+    if (my $config_file = $self->config_file) {
+        my $config_opts = do $config_file;
+
+        croak "Error reading config from $config_file: $@" if $@;
+
+        croak "Config file $config_file must be a hashref" unless ref($config_opts) eq 'HASH';
+
+        while (my ($k, $v) = each %$config_opts) {
+            $self->{$k} = $v unless exists $self->{$k};
+        }
+    }
+
     $self->_ensure_arrayref(qw/additional_classes
                                additional_base_classes
                                left_base_classes
@@ -499,7 +521,7 @@ sub new {
 
     if ($self->naming) {
         for (values %{ $self->naming }) {
-            $_ = CURRENT_V if $_ eq 'current';
+            $_ = $CURRENT_V if $_ eq 'current';
         }
     }
     $self->{naming} ||= {};
@@ -613,7 +635,7 @@ EOF
             my ($v) = $real_ver =~ /([1-9])/;
             $v = "v$v";
 
-            last if $v eq CURRENT_V || $real_ver =~ /^0\.\d\d999/;
+            last if $v eq $CURRENT_V || $real_ver =~ /^0\.\d\d999/;
 
             if (not %{ $self->naming }) {
                 warn <<"EOF" unless $ENV{SCHEMA_LOADER_BACKCOMPAT};
@@ -647,7 +669,7 @@ sub _validate_class_args {
     my $self = shift;
     my $args = shift;
     
-    foreach my $k (CLASS_ARGS) {
+    foreach my $k (@CLASS_ARGS) {
         next unless $self->$k;
 
         my @classes = ref $self->$k eq 'ARRAY' ? @{ $self->$k } : $self->$k;
@@ -794,9 +816,7 @@ sub _load_external {
 # upgrade. See skip_load_external to disable this feature.
 EOF
 
-        my $code = do {
-            local ($/, @ARGV) = (undef, $old_real_inc_path); <>
-        };
+        my $code = slurp $old_real_inc_path;
         $code = $self->_rewrite_old_classnames($code);
 
         if ($self->dynamic) {
@@ -912,6 +932,34 @@ sub _load_tables {
     }
 
     $self->_make_src_class($_) for @tables;
+
+
+    # sanity-check for moniker clashes
+    my $inverse_moniker_idx;
+    for (keys %{$self->monikers}) {
+      push @{$inverse_moniker_idx->{$self->monikers->{$_}}}, $_;
+    }
+
+    my @clashes;
+    for (keys %$inverse_moniker_idx) {
+      my $tables = $inverse_moniker_idx->{$_};
+      if (@$tables > 1) {
+        push @clashes, sprintf ("tables %s reduced to the same source moniker '%s'",
+          join (', ', map { "'$_'" } @$tables),
+          $_,
+        );
+      }
+    }
+
+    if (@clashes) {
+      die   'Unable to load schema - chosen moniker/class naming style results in moniker clashes. '
+          . 'Either change the naming style, or supply an explicit moniker_map: '
+          . join ('; ', @clashes)
+          . "\n"
+      ;
+    }
+
+
     $self->_setup_src_meta($_) for @tables;
 
     if(!$self->skip_relationships) {
@@ -1350,34 +1398,28 @@ sub _setup_src_meta {
     $self->_dbic_stmt($table_class,'table',$table_name);
 
     my $cols = $self->_table_columns($table);
-    my $col_info;
-    eval { $col_info = $self->__columns_info_for($table) };
-    if($@) {
-        $self->_dbic_stmt($table_class,'add_columns',@$cols);
-    }
-    else {
-        if ($self->_is_case_sensitive) {
-            for my $col (keys %$col_info) {
-                $col_info->{$col}{accessor} = lc $col
-                    if $col ne lc($col);
-            }
-        } else {
-            $col_info = { map { lc($_), $col_info->{$_} } keys %$col_info };
+    my $col_info = $self->__columns_info_for($table);
+    if ($self->_is_case_sensitive) {
+        for my $col (keys %$col_info) {
+            $col_info->{$col}{accessor} = lc $col
+                if $col ne lc($col);
         }
+    } else {
+        $col_info = { map { lc($_), $col_info->{$_} } keys %$col_info };
+    }
 
-        my $fks = $self->_table_fk_info($table);
+    my $fks = $self->_table_fk_info($table);
 
-        for my $fkdef (@$fks) {
-            for my $col (@{ $fkdef->{local_columns} }) {
-                $col_info->{$col}{is_foreign_key} = 1;
-            }
+    for my $fkdef (@$fks) {
+        for my $col (@{ $fkdef->{local_columns} }) {
+            $col_info->{$col}{is_foreign_key} = 1;
         }
-        $self->_dbic_stmt(
-            $table_class,
-            'add_columns',
-            map { $_, ($col_info->{$_}||{}) } @$cols
-        );
     }
+    $self->_dbic_stmt(
+        $table_class,
+        'add_columns',
+        map { $_, ($col_info->{$_}||{}) } @$cols
+    );
 
     my %uniq_tag; # used to eliminate duplicate uniqs
 
@@ -1550,8 +1592,15 @@ sub _make_pod {
                             my $s = $attrs->{$_};
                             $s = !defined $s         ? 'undef'          :
                                   length($s) == 0     ? '(empty string)' :
-                                  ref($s) eq 'SCALAR' ? $$s              :
-                                                        $s
+                                  ref($s) eq 'SCALAR' ? $$s :
+                                  ref($s)             ? do {
+                                                        my $dd = Dumper;
+                                                        $dd->Indent(0);
+                                                        $dd->Values([$s]);
+                                                        $dd->Dump;
+                                                      } :
+                                  looks_like_number($s) ? $s :
+                                                        qq{'$s'}
                                   ;
 
                             "  $_: $s"