From: Rafael Kitover <rkitover@cpan.org>
Date: Mon, 28 Dec 2009 17:26:59 +0000 (+0000)
Subject: preserve custom content from un-singularized Results during upgrade
X-Git-Tag: 0.04999_13~20
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=f53dcdf015a19537f0bde292971ba3d90a37d9a8;p=dbsrgits%2FDBIx-Class-Schema-Loader.git

preserve custom content from un-singularized Results during upgrade
---

diff --git a/TODO-BACKCOMPAT b/TODO-BACKCOMPAT
index b8fe2b1..1141078 100644
--- a/TODO-BACKCOMPAT
+++ b/TODO-BACKCOMPAT
@@ -2,8 +2,11 @@ SL Backcompat Plan:
 
 *** 0.04006 mode
 
-* preserve custom content from un-singularized Results and delete them when in
-  upgrade mode
+* get custom content from un-singularized classes in _load_external, with an
+  appropriate comment that it's during upgrade only, for both static and
+  dynamic schemas
+
+* make use_namespaces the default, and upgrade to it properly
 
 *** Catalyst Helper
 
diff --git a/lib/DBIx/Class/Schema/Loader/Base.pm b/lib/DBIx/Class/Schema/Loader/Base.pm
index 16507e7..0997ad7 100644
--- a/lib/DBIx/Class/Schema/Loader/Base.pm
+++ b/lib/DBIx/Class/Schema/Loader/Base.pm
@@ -47,15 +47,16 @@ __PACKAGE__->mk_ro_accessors(qw/
                                 db_schema
                                 _tables
                                 classes
+                                _upgrading_classes
                                 monikers
                                 dynamic
                                 naming
-                                _upgrading_from
                              /);
 
 __PACKAGE__->mk_accessors(qw/
                                 version_to_dump
                                 schema_version_to_dump
+                                _upgrading_from
 /);
 
 =head1 NAME
@@ -331,6 +332,7 @@ sub new {
 
     $self->{monikers} = {};
     $self->{classes} = {};
+    $self->{_upgrading_classes} = {};
 
     $self->{schema_class} ||= ( ref $self->{schema} || $self->{schema} );
     $self->{schema} ||= $self->{schema_class};
@@ -390,6 +392,9 @@ See perldoc DBIx::Class::Schema::Loader::Manual::UpgradingFromV4 for more
 details.
 EOF
         }
+        else {
+            $self->_upgrading_from('v4');
+        }
 
         $self->naming->{relationships} ||= 'v4';
         $self->naming->{monikers}      ||= 'v4';
@@ -426,6 +431,9 @@ See perldoc DBIx::Class::Schema::Loader::Manual::UpgradingFromV4 for more
 details.
 EOF
             }
+            else {
+                $self->_upgrading_from($v);
+            }
 
             $self->naming->{relationships} ||= $v;
             $self->naming->{monikers}      ||= $v;
@@ -671,6 +679,12 @@ sub _reload_class {
 
     my $class_path = $self->_class_path($class);
     delete $INC{ $class_path };
+
+# kill redefined warnings
+    local $SIG{__WARN__} = sub {
+        warn @_ unless $_[0] =~ /^Subroutine \S+ redefined/;
+    };
+
     eval "require $class;";
 }
 
@@ -776,6 +790,23 @@ sub _write_classfile {
 
     my ($custom_content, $old_md5, $old_ver, $old_ts) = $self->_get_custom_content($class, $filename);
 
+    if ($self->_upgrading_from) {
+        my $old_class = $self->_upgrading_classes->{$class};
+
+        if ($old_class && ($old_class ne $class)) {
+            my $old_filename = $self->_get_dump_filename($old_class);
+
+            my ($old_custom_content) = $self->_get_custom_content(
+                $old_class, $old_filename
+            );
+
+            $custom_content .= "\n" . $old_custom_content
+                if $old_custom_content;
+
+            unlink $old_filename;
+        }
+    }
+
     $text .= qq|$_\n|
         for @{$self->{_dump_storage}->{$class} || []};
 
@@ -903,6 +934,15 @@ sub _make_src_class {
     }
     my $table_class = join(q{::}, @result_namespace, $table_moniker);
 
+    if (my $upgrading_v = $self->_upgrading_from) {
+        local $self->naming->{monikers} = $upgrading_v;
+
+        my $old_class = join(q{::}, @result_namespace,
+            $self->_table2moniker($table));
+
+        $self->_upgrading_classes->{$table_class} = $old_class;
+    }
+
     my $table_normalized = lc $table;
     $self->classes->{$table} = $table_class;
     $self->classes->{$table_normalized} = $table_class;
diff --git a/t/25backcompat_v4.t b/t/25backcompat_v4.t
index 8c22c2c..c67c7fb 100644
--- a/t/25backcompat_v4.t
+++ b/t/25backcompat_v4.t
@@ -13,7 +13,14 @@ my $SCHEMA_CLASS = 'DBIXCSL_Test::Schema';
 sub run_loader {
     my %loader_opts = @_;
 
-    Class::Unload->unload($SCHEMA_CLASS);
+    eval {
+        foreach my $source_name ($SCHEMA_CLASS->clone->sources) {
+            Class::Unload->unload("${SCHEMA_CLASS}::${source_name}");
+        }
+
+        Class::Unload->unload($SCHEMA_CLASS);
+    };
+    undef $@;
 
     my @connect_info = $make_dbictest_db2::dsn;
     my @loader_warnings;
@@ -103,6 +110,8 @@ sub run_v5_tests {
     my $res = run_loader(naming => 'v4');
 
     is_deeply $res->{warnings}, [], 'no warnings with naming attribute set';
+
+    run_v4_tests($res);
 }
 
 # test upgraded dynamic schema
@@ -121,7 +130,6 @@ sub run_v5_tests {
     run_v5_tests($res);
 }
 
-
 # test running against v4 schema without upgrade
 {
     # write out the 0.04006 Schema.pm we have in __DATA__
@@ -175,7 +183,8 @@ sub run_v5_tests {
         'correct warnings on upgrading static schema (with "naming" set)';
 
     is scalar @{ $res->{warnings} }, 2,
-'correct number of warnings on upgrading static schema (with "naming" set)';
+'correct number of warnings on upgrading static schema (with "naming" set)'
+        or diag @{ $res->{warnings} };
 
     run_v5_tests($res);