rewrite un-singularized classnames in custom and external content when upgrading
Rafael Kitover [Sun, 3 Jan 2010 11:24:56 +0000 (11:24 +0000)]
TODO-BACKCOMPAT
lib/DBIx/Class/Schema/Loader/Base.pm
t/25backcompat_v4.t
t/lib/make_dbictest_db2.pm

index 17a46d3..08eda1c 100644 (file)
@@ -1,8 +1,5 @@
 SL Backcompat Plan:
 
-* rewrite un-singularized class names (in e.g. custom relationships) in both
-  preserved custom content and external content from un-singularized classes
-
 * make use_namespaces the default, and upgrade to it properly
 
 *** Catalyst Helper
index 5b334ff..420728a 100644 (file)
@@ -460,7 +460,7 @@ EOF
             my ($v) = $real_ver =~ /([1-9])/;
             $v = "v$v";
 
-            last if $v eq CURRENT_V || $real_ver =~ /^0\.04999/;
+            last if $v eq CURRENT_V || $real_ver =~ /^0\.\d\d999/;
 
             if (not %{ $self->naming }) {
                 warn <<"EOF" unless $ENV{SCHEMA_LOADER_BACKCOMPAT};
@@ -518,6 +518,21 @@ sub _find_class_in_inc {
     return $self->_find_file_in_inc($self->_class_path($class));
 }
 
+sub _rewrite_old_classnames {
+    my ($self, $code) = @_;
+
+    return $code unless $self->_upgrading_from;
+
+    my %old_classes = reverse %{ $self->_upgrading_classes };
+
+    my $re = join '|', keys %old_classes;
+    $re = qr/\b($re)\b/;
+
+    $code =~ s/$re/$old_classes{$1}/eg;
+
+    return $code;
+}
+
 sub _load_external {
     my ($self, $class) = @_;
 
@@ -543,23 +558,10 @@ sub _load_external {
 
         open(my $fh, '<', $real_inc_path)
             or croak "Failed to open '$real_inc_path' for reading: $!";
-        $self->_ext_stmt($class,
-          qq|# These lines were loaded from '$real_inc_path' found in \@INC.\n|
-         .qq|# They are now part of the custom portion of this file\n|
-         .qq|# for you to hand-edit.  If you do not either delete\n|
-         .qq|# this section or remove that file from \@INC, this section\n|
-         .qq|# will be repeated redundantly when you re-create this\n|
-         .qq|# file again via Loader!\n|
-        );
-        while(<$fh>) {
-            chomp;
-            $self->_ext_stmt($class, $_);
-        }
-        $self->_ext_stmt($class,
-            qq|# End of lines loaded from '$real_inc_path' |
-        );
+        my $code = do { local $/; <$fh> };
         close($fh)
             or croak "Failed to close $real_inc_path: $!";
+        $code = $self->_rewrite_old_classnames($code);
 
         if ($self->dynamic) { # load the class too
             # kill redefined warnings
@@ -568,9 +570,23 @@ sub _load_external {
                 $warn_handler->(@_)
                     unless $_[0] =~ /^Subroutine \S+ redefined/;
             };
-            do $real_inc_path;
+            eval $code;
             die $@ if $@;
         }
+
+        $self->_ext_stmt($class,
+          qq|# These lines were loaded from '$real_inc_path' found in \@INC.\n|
+         .qq|# They are now part of the custom portion of this file\n|
+         .qq|# for you to hand-edit.  If you do not either delete\n|
+         .qq|# this section or remove that file from \@INC, this section\n|
+         .qq|# will be repeated redundantly when you re-create this\n|
+         .qq|# file again via Loader!\n|
+        );
+        chomp $code;
+        $self->_ext_stmt($class, $code);
+        $self->_ext_stmt($class,
+            qq|# End of lines loaded from '$real_inc_path' |
+        );
     }
 
     if ($old_real_inc_path) {
@@ -583,6 +599,12 @@ sub _load_external {
 # version of the Loader. For a static schema, this happens only once during
 # upgrade.
 EOF
+
+        my $code = do {
+            local ($/, @ARGV) = (undef, $old_real_inc_path); <>
+        };
+        $code = $self->_rewrite_old_classnames($code);
+
         if ($self->dynamic) {
             warn <<"EOF";
 
@@ -598,25 +620,15 @@ EOF
                 $warn_handler->(@_)
                     unless $_[0] =~ /^Subroutine \S+ redefined/;
             };
-            my $code = do {
-                local ($/, @ARGV) = (undef, $old_real_inc_path); <>
-            };
-            $code =~ s/\b$old_class\b/$class/g;
             eval $code;
             die $@ if $@;
         }
 
-        while(<$fh>) {
-            chomp;
-            s/\b$old_class\b/$class/g;
-            $self->_ext_stmt($class, $_);
-        }
+        chomp $code;
+        $self->_ext_stmt($class, $code);
         $self->_ext_stmt($class,
             qq|# End of lines loaded from '$old_real_inc_path' |
         );
-
-        close($fh)
-            or croak "Failed to close $old_real_inc_path: $!";
     }
 }
 
@@ -921,6 +933,8 @@ sub _write_classfile {
         }
     }
 
+    $custom_content = $self->_rewrite_old_classnames($custom_content);
+
     $text .= qq|$_\n|
         for @{$self->{_dump_storage}->{$class} || []};
 
index 993d128..384fe96 100644 (file)
@@ -1,6 +1,7 @@
 use strict;
 use warnings;
 use Test::More;
+use Test::Exception;
 use File::Path qw/rmtree make_path/;
 use Class::Unload;
 use File::Temp qw/tempfile tempdir/;
@@ -61,9 +62,24 @@ my $SCHEMA_CLASS = 'DBIXCSL_Test::Schema';
     my $external_result_dir = join '/', $temp_dir, split /::/, $SCHEMA_CLASS;
     make_path $external_result_dir;
 
+    # make external content for Result that will be singularized
     IO::File->new(">$external_result_dir/Quuxs.pm")->print(<<"EOF");
 package ${SCHEMA_CLASS}::Quuxs;
 sub a_method { 'hlagh' }
+
+__PACKAGE__->has_one('bazrel', 'DBIXCSL_Test::Schema::Bazs',
+    { 'foreign.baz_num' => 'self.baz_id' });
+
+1;
+EOF
+
+    # make external content for Result that will NOT be singularized
+    IO::File->new(">$external_result_dir/Bar.pm")->print(<<"EOF");
+package ${SCHEMA_CLASS}::Bar;
+
+__PACKAGE__->has_one('foorel', 'DBIXCSL_Test::Schema::Foos',
+    { 'foreign.fooid' => 'self.foo_id' });
+
 1;
 EOF
 
@@ -78,10 +94,19 @@ EOF
     like $warning, qr/Detected external content/i,
         'detected external content warning';
 
-    is eval { $schema->resultset('Quux')->find(1)->a_method }, 'hlagh',
+    lives_and { is $schema->resultset('Quux')->find(1)->a_method, 'hlagh' }
 'external custom content for unsingularized Result was loaded by upgraded ' .
 'dynamic Schema';
 
+    lives_and { isa_ok $schema->resultset('Quux')->find(1)->bazrel,
+        $res->{classes}{bazs} }
+        'unsingularized class names in external content are translated';
+
+    lives_and { isa_ok $schema->resultset('Bar')->find(1)->foorel,
+        $res->{classes}{foos} }
+'unsingularized class names in external content from unchanged Result class ' .
+'names are translated';
+
     run_v5_tests($res);
 
     rmtree $temp_dir;
@@ -96,9 +121,24 @@ EOF
     my $external_result_dir = join '/', $temp_dir, split /::/, $SCHEMA_CLASS;
     make_path $external_result_dir;
 
+    # make external content for Result that will be singularized
     IO::File->new(">$external_result_dir/Quuxs.pm")->print(<<"EOF");
 package ${SCHEMA_CLASS}::Quuxs;
 sub a_method { 'dongs' }
+
+__PACKAGE__->has_one('bazrel2', 'DBIXCSL_Test::Schema::Bazs',
+    { 'foreign.baz_num' => 'self.baz_id' });
+
+1;
+EOF
+
+    # make external content for Result that will NOT be singularized
+    IO::File->new(">$external_result_dir/Bar.pm")->print(<<"EOF");
+package ${SCHEMA_CLASS}::Bar;
+
+__PACKAGE__->has_one('foorel2', 'DBIXCSL_Test::Schema::Foos',
+    { 'foreign.fooid' => 'self.foo_id' });
+
 1;
 EOF
 
@@ -109,10 +149,19 @@ EOF
 
     run_v5_tests($res);
 
-    is eval { $schema->resultset('Quux')->find(1)->a_method }, 'dongs',
+    lives_and { is $schema->resultset('Quux')->find(1)->a_method, 'dongs' }
 'external custom content for unsingularized Result was loaded by upgraded ' .
 'static Schema';
 
+    lives_and { isa_ok $schema->resultset('Quux')->find(1)->bazrel2,
+        $res->{classes}{bazs} }
+        'unsingularized class names in external content are translated';
+
+    lives_and { isa_ok $schema->resultset('Bar')->find(1)->foorel2,
+        $res->{classes}{foos} }
+'unsingularized class names in external content from unchanged Result class ' .
+'names are translated in static schema';
+
     my $file = $schema->_loader->_get_dump_filename($res->{classes}{quuxs});
     my $code = do { local ($/, @ARGV) = (undef, $file); <> };
 
@@ -126,7 +175,7 @@ EOF
     pop @INC;
 }
 
-# test running against v4 schema without upgrade
+# test running against v4 schema without upgrade, twice, then upgrade
 {
     write_v4_schema_pm();
 
@@ -155,7 +204,12 @@ EOF
         while (<>) {
             if (/DO NOT MODIFY THIS OR ANYTHING ABOVE/) {
                 print;
-                print "sub a_method { 'mtfnpy' }\n";
+                print <<EOF;
+sub a_method { 'mtfnpy' }
+
+__PACKAGE__->has_one('bazrel3', 'DBIXCSL_Test::Schema::Bazs',
+    { 'foreign.baz_num' => 'self.baz_id' });
+EOF
             }
             else {
                 print;
@@ -163,6 +217,11 @@ EOF
         }
     }
 
+    # Rerun the loader in backcompat mode to make sure it's still in backcompat
+    # mode.
+    $res = run_loader(dump_directory => $DUMP_DIR);
+    run_v4_tests($res);
+
     # now upgrade the schema
     $res = run_loader(dump_directory => $DUMP_DIR, naming => 'current');
     $schema = $res->{schema};
@@ -186,8 +245,69 @@ EOF
         'un-singularized results were replaced during upgrade';
 
     # check that custom content was preserved
-    is eval { $schema->resultset('Quux')->find(1)->a_method }, 'mtfnpy',
+    lives_and { is $schema->resultset('Quux')->find(1)->a_method, 'mtfnpy' }
         'custom content was carried over from un-singularized Result';
+
+    lives_and { isa_ok $schema->resultset('Quux')->find(1)->bazrel3,
+        $res->{classes}{bazs} }
+        'unsingularized class names in custom content are translated';
+
+    my $file = $schema->_loader->_get_dump_filename($res->{classes}{quuxs});
+    my $code = do { local ($/, @ARGV) = (undef, $file); <> };
+
+    like $code, qr/sub a_method { 'mtfnpy' }/,
+'custom content from unsingularized Result loaded into static dump correctly';
+}
+
+# Test upgrading an already singular result with custom content that refers to
+# old class names.
+{
+    write_v4_schema_pm();
+    my $res = run_loader(dump_directory => $DUMP_DIR);
+    my $schema   = $res->{schema};
+    run_v4_tests($res);
+
+    # add some custom content to a Result that will be replaced
+    my $bar_pm = $schema->_loader
+        ->_get_dump_filename($res->{classes}{bar});
+    {
+        local ($^I, @ARGV) = ('', $bar_pm);
+        while (<>) {
+            if (/DO NOT MODIFY THIS OR ANYTHING ABOVE/) {
+                print;
+                print <<EOF;
+sub a_method { 'lalala' }
+
+__PACKAGE__->has_one('foorel3', 'DBIXCSL_Test::Schema::Foos',
+    { 'foreign.fooid' => 'self.foo_id' });
+EOF
+            }
+            else {
+                print;
+            }
+        }
+    }
+
+    # now upgrade the schema
+    $res = run_loader(dump_directory => $DUMP_DIR, naming => 'current');
+    $schema = $res->{schema};
+    run_v5_tests($res);
+
+    # check that custom content was preserved
+    lives_and { is $schema->resultset('Bar')->find(1)->a_method, 'lalala' }
+        'custom content was preserved from Result pre-upgrade';
+
+    lives_and { isa_ok $schema->resultset('Bar')->find(1)->foorel3,
+        $res->{classes}{foos} }
+'unsingularized class names in custom content from Result with unchanged ' .
+'name are translated';
+
+    my $file = $schema->_loader->_get_dump_filename($res->{classes}{bar});
+    my $code = do { local ($/, @ARGV) = (undef, $file); <> };
+
+    like $code, qr/sub a_method { 'lalala' }/,
+'custom content from Result with unchanged name loaded into static dump ' .
+'correctly';
 }
 
 done_testing;
index 5a00179..f927da6 100644 (file)
@@ -20,7 +20,7 @@ $dbh->do($_) for (
       )|,
     q|CREATE TABLE bar (
         barid INTEGER PRIMARY KEY,
-        foo_id INTEGER REFERENCES foos (fooid)
+        foo_id INTEGER NOT NULL REFERENCES foos (fooid)
       )|,
     q|CREATE TABLE bazs (
         bazid INTEGER PRIMARY KEY,