From: Peter Rabbitson <ribasushi@cpan.org>
Date: Wed, 8 Sep 2010 17:33:57 +0000 (+0200)
Subject: ARGH! use_moose => 1, reload without any option, BOOM
X-Git-Tag: 0.07002~6
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?p=dbsrgits%2FDBIx-Class-Schema-Loader.git;a=commitdiff_plain;h=8de81918c82b582587eaeb905bac03deaeef9061

ARGH! use_moose => 1, reload without any option, BOOM
---

diff --git a/Changes b/Changes
index 703e85d..66b4f1f 100644
--- a/Changes
+++ b/Changes
@@ -1,5 +1,7 @@
 Revision history for Perl extension DBIx::Class::Schema::Loader
 
+        - Properly detect a schema loaded with use_moose on subsequent
+          reloads
         - Switch to MRO::Compat
         - Fix oracle common tests failure / lc(undef) warnings
         - Bump Moose/Moosex::NonMoose optional dependencies to fixed-up
diff --git a/lib/DBIx/Class/Schema/Loader/Base.pm b/lib/DBIx/Class/Schema/Loader/Base.pm
index b2e4d95..6927b29 100644
--- a/lib/DBIx/Class/Schema/Loader/Base.pm
+++ b/lib/DBIx/Class/Schema/Loader/Base.pm
@@ -52,7 +52,7 @@ __PACKAGE__->mk_group_ro_accessors('simple', qw/
                                 schema_base_class
                                 result_base_class
                                 use_moose
-				overwrite_modifications
+                                overwrite_modifications
 
                                 relationship_attrs
 
@@ -521,6 +521,11 @@ sub new {
 
     my $self = { %args };
 
+    # don't lose undef options
+    for (values %$self) {
+        $_ = 0 unless defined $_;
+    }
+
     bless $self => $class;
 
     if (my $config_file = $self->config_file) {
@@ -650,22 +655,21 @@ EOF
     my $filename = $self->_get_dump_filename($self->schema_class);
     return unless -e $filename;
 
-    open(my $fh, '<', $filename)
-        or croak "Cannot open '$filename' for reading: $!";
+    my ($old_gen, $old_md5, $old_ver, $old_ts, $old_custom) =
+      $self->_parse_generated_file($filename);
 
-    my $load_classes     = 0;
-    my $result_namespace = '';
+    return unless $old_ver;
+
+    # determine if the existing schema was dumped with use_moose => 1
+    if (! defined $self->use_moose) {
+        $self->use_moose(1) if $old_gen =~ /^ (?!\s*\#) use \s+ Moose/xm;
+    }
 
-    while (<$fh>) {
-        if (/^__PACKAGE__->load_classes;/) {
-            $load_classes = 1;
-        } elsif (/result_namespace => '([^']+)'/) {
-            $result_namespace = $1;
-        } elsif (my ($real_ver) =
-                /^# Created by DBIx::Class::Schema::Loader v(\d+\.\d+)/) {
+    my $load_classes = ($old_gen =~ /^__PACKAGE__->load_classes;/m) ? 1 : 0;
+    my $result_namespace = do { ($old_gen =~ /result_namespace => '([^']+)'/) ? $1 : '' };
 
-            if ($load_classes && (not defined $self->use_namespaces)) {
-                warn <<"EOF"  unless $ENV{SCHEMA_LOADER_BACKCOMPAT};
+    if ($load_classes && (not defined $self->use_namespaces)) {
+        warn <<"EOF"  unless $ENV{SCHEMA_LOADER_BACKCOMPAT};
 
 'load_classes;' static schema detected, turning off 'use_namespaces'.
 
@@ -675,39 +679,37 @@ variable to disable this warning.
 See perldoc DBIx::Class::Schema::Loader::Manual::UpgradingFromV4 for more
 details.
 EOF
-                $self->use_namespaces(0);
-            }
-            elsif ($load_classes && $self->use_namespaces) {
-                $self->_upgrading_from_load_classes(1);
-            }
-            elsif ((not $load_classes) && defined $self->use_namespaces
-                                       && (not $self->use_namespaces)) {
-                $self->_downgrading_to_load_classes(
-                    $result_namespace || 'Result'
-                );
-            }
-            elsif ((not defined $self->use_namespaces)
-                   || $self->use_namespaces) {
-                if (not $self->result_namespace) {
-                    $self->result_namespace($result_namespace || 'Result');
-                }
-                elsif ($result_namespace ne $self->result_namespace) {
-                    $self->_rewriting_result_namespace(
-                        $result_namespace || 'Result'
-                    );
-                }
-            }
+        $self->use_namespaces(0);
+    }
+    elsif ($load_classes && $self->use_namespaces) {
+        $self->_upgrading_from_load_classes(1);
+    }
+    elsif ((not $load_classes) && defined $self->use_namespaces && ! $self->use_namespaces) {
+        $self->_downgrading_to_load_classes(
+            $result_namespace || 'Result'
+        );
+    }
+    elsif ((not defined $self->use_namespaces) || $self->use_namespaces) {
+        if (not $self->result_namespace) {
+            $self->result_namespace($result_namespace || 'Result');
+        }
+        elsif ($result_namespace ne $self->result_namespace) {
+            $self->_rewriting_result_namespace(
+                $result_namespace || 'Result'
+            );
+        }
+    }
 
-            # XXX when we go past .0 this will need fixing
-            my ($v) = $real_ver =~ /([1-9])/;
-            $v = "v$v";
+    # XXX when we go past .0 this will need fixing
+    my ($v) = $old_ver =~ /([1-9])/;
+    $v = "v$v";
 
-            last if $v eq $CURRENT_V || $real_ver =~ /^0\.\d\d999/;
+    return if ($v eq $CURRENT_V || $old_ver =~ /^0\.\d\d999/);
 
-            if (not %{ $self->naming }) {
-                warn <<"EOF" unless $ENV{SCHEMA_LOADER_BACKCOMPAT};
+    if (not %{ $self->naming }) {
+        warn <<"EOF" unless $ENV{SCHEMA_LOADER_BACKCOMPAT};
 
-Version $real_ver static schema detected, turning on backcompat mode.
+Version $old_ver static schema detected, turning on backcompat mode.
 
 Set the 'naming' attribute or the SCHEMA_LOADER_BACKCOMPAT environment variable
 to disable this warning.
@@ -717,28 +719,22 @@ See: 'naming' in perldoc DBIx::Class::Schema::Loader::Base .
 See perldoc DBIx::Class::Schema::Loader::Manual::UpgradingFromV4 if upgrading
 from version 0.04006.
 EOF
-            }
-            else {
-                $self->_upgrading_from($v);
-                last;
-            }
-
-            $self->naming->{relationships}    ||= $v;
-            $self->naming->{monikers}         ||= $v;
-            $self->naming->{column_accessors} ||= $v;
 
-            $self->schema_version_to_dump($real_ver);
+        $self->naming->{relationships}    ||= $v;
+        $self->naming->{monikers}         ||= $v;
+        $self->naming->{column_accessors} ||= $v;
 
-            last;
-        }
+        $self->schema_version_to_dump($old_ver);
+    }
+    else {
+        $self->_upgrading_from($v);
     }
-    close $fh;
 }
 
 sub _validate_class_args {
     my $self = shift;
     my $args = shift;
-    
+
     foreach my $k (@CLASS_ARGS) {
         next unless $self->$k;
 
@@ -1274,44 +1270,51 @@ sub _write_classfile {
         warn "Deleting existing file '$filename' due to "
             . "'really_erase_my_files' setting\n" unless $self->{quiet};
         unlink($filename);
-    }    
+    }
 
-    my ($custom_content, $old_md5, $old_ver, $old_ts) = $self->_get_custom_content($class, $filename);
+    my ($old_gen, $old_md5, $old_ver, $old_ts, $old_custom)
+        = $self->_parse_generated_file($filename);
 
-    # If upgrading to use_moose=1 replace default custom content with default Moose custom content.
-    # If there is already custom content, which does not have the Moose content, add it.
-    if ($self->use_moose) {
-        local $self->{use_moose} = 0;
+    if (! $old_gen && -f $filename) {
+        croak "Cannot overwrite '$filename' without 'really_erase_my_files',"
+            . " it does not appear to have been generated by Loader"
+    }
 
-        if ($custom_content eq $self->_default_custom_content) {
-            local $self->{use_moose} = 1;
+    my $custom_content = $old_custom || '';
 
-            $custom_content = $self->_default_custom_content;
-        }
-        else {
-            local $self->{use_moose} = 1;
+    # prepend extra custom content from a *renamed* class (singularization effect)
+    if (my $renamed_class = $self->_upgrading_classes->{$class}) {
+        my $old_filename = $self->_get_dump_filename($renamed_class);
 
-            if ($custom_content !~ /\Q@{[$self->_default_moose_custom_content]}\E/) {
-                $custom_content .= $self->_default_custom_content;
-            }
+        if (-f $old_filename) {
+            my $extra_custom = ($self->_parse_generated_file ($old_filename))[4];
+
+            $extra_custom =~ s/\n\n# You can replace.*\n1;\n//;
+
+            $custom_content = join ("\n", '', $extra_custom, $custom_content)
+                if $extra_custom;
+
+            unlink $old_filename;
         }
     }
 
-    if (my $old_class = $self->_upgrading_classes->{$class}) {
-        my $old_filename = $self->_get_dump_filename($old_class);
+    $custom_content ||= $self->_default_custom_content;
 
-        my ($old_custom_content) = $self->_get_custom_content(
-            $old_class, $old_filename, 0 # do not add default comment
-        );
+    # If upgrading to use_moose=1 replace default custom content with default Moose custom content.
+    # If there is already custom content, which does not have the Moose content, add it.
+    if ($self->use_moose) {
 
-        $old_custom_content =~ s/\n\n# You can replace.*\n1;\n//;
+        my $non_moose_custom_content = do {
+            local $self->{use_moose} = 0;
+            $self->_default_custom_content;
+        };
 
-        if ($old_custom_content) {
-            $custom_content =
-                "\n" . $old_custom_content . "\n" . $custom_content;
+        if ($custom_content eq $non_moose_custom_content) {
+            $custom_content = $self->_default_custom_content;
+        }
+        elsif ($custom_content !~ /\Q@{[$self->_default_moose_custom_content]}\E/) {
+            $custom_content .= $self->_default_custom_content;
         }
-
-        unlink $old_filename;
     }
 
     $custom_content = $self->_rewrite_old_classnames($custom_content);
@@ -1324,8 +1327,6 @@ sub _write_classfile {
     my $compare_to;
     if ($old_md5) {
       $compare_to = $text . $self->_sig_comment($old_ver, $old_ts);
-      
-
       if (Digest::MD5::md5_base64($compare_to) eq $old_md5) {
         return unless $self->_upgrading_from && $is_schema;
       }
@@ -1368,48 +1369,43 @@ sub _default_custom_content {
     return $default;
 }
 
-sub _get_custom_content {
-    my ($self, $class, $filename, $add_default) = @_;
-
-    $add_default = 1 unless defined $add_default;
+sub _parse_generated_file {
+    my ($self, $fn) = @_;
 
-    return ($self->_default_custom_content) if ! -f $filename;
+    return unless -f $fn;
 
-    open(my $fh, '<', $filename)
-        or croak "Cannot open '$filename' for reading: $!";
+    open(my $fh, '<', $fn)
+        or croak "Cannot open '$fn' for reading: $!";
 
-    my $mark_re = 
+    my $mark_re =
         qr{^(# DO NOT MODIFY THIS OR ANYTHING ABOVE! md5sum:)([A-Za-z0-9/+]{22})\n};
 
-    my $buffer = '';
-    my ($md5, $ts, $ver);
+    my ($md5, $ts, $ver, $gen);
     while(<$fh>) {
-        if(!$md5 && /$mark_re/) {
+        if(/$mark_re/) {
+            my $pre_md5 = $1;
             $md5 = $2;
-            my $line = $1;
 
-            # Pull out the previous version and timestamp
-            ($ver, $ts) = $buffer =~ m/# Created by DBIx::Class::Schema::Loader v(.*?) @ (.*?)$/s;
+            # Pull out the version and timestamp from the line above
+            ($ver, $ts) = $gen =~ m/^# Created by DBIx::Class::Schema::Loader v(.*?) @ (.*?)\Z/m;
 
-            $buffer .= $line;
-            croak "Checksum mismatch in '$filename', the auto-generated part of the file has been modified outside of this loader.  Aborting.\nIf you want to overwrite these modifications, set the 'overwrite_modifications' loader option.\n"
-                if !$self->overwrite_modifications && Digest::MD5::md5_base64($buffer) ne $md5;
+            $gen .= $pre_md5;
+            croak "Checksum mismatch in '$fn', the auto-generated part of the file has been modified outside of this loader.  Aborting.\nIf you want to overwrite these modifications, set the 'overwrite_modifications' loader option.\n"
+                if !$self->overwrite_modifications && Digest::MD5::md5_base64($gen) ne $md5;
 
-            $buffer = '';
+            last;
         }
         else {
-            $buffer .= $_;
+            $gen .= $_;
         }
     }
 
-    croak "Cannot not overwrite '$filename' without 'really_erase_my_files',"
-        . " it does not appear to have been generated by Loader"
-            if !$md5;
+    my $custom = do { local $/; <$fh> }
+        if $md5;
 
-    # Default custom content:
-    $buffer ||= $self->_default_custom_content if $add_default;
+    close ($fh);
 
-    return ($buffer, $md5, $ver, $ts);
+    return ($gen, $md5, $ver, $ts, $custom);
 }
 
 sub _use {
diff --git a/t/26dump_use_moose.t b/t/26dump_use_moose.t
index ac1830c..1310455 100644
--- a/t/26dump_use_moose.t
+++ b/t/26dump_use_moose.t
@@ -126,39 +126,42 @@ $t->dump_test(
 );
 
 # add Moose custom content then check it is not repeated
-
+# after that regen again *without* the use_moose flag, make
+# sure moose isn't stripped away
 $t->append_to_class('DBICTest::DumpMore::1::Foo', qq{__PACKAGE__->meta->make_immutable;\n1;\n});
 
-$t->dump_test(
-  classname => 'DBICTest::DumpMore::1',
-  options => {
-    use_moose => 1,
-    result_base_class => 'My::ResultBaseClass',
-    schema_base_class => 'My::SchemaBaseClass',
-  },
-  warnings => [
-    qr/Dumping manual schema for DBICTest::DumpMore::1 to directory /,
-    qr/Schema dump completed/,
-  ],
-  regexes => {
-    schema => [
-      qr/\nuse Moose;\nuse MooseX::NonMoose;\nuse namespace::autoclean;\nextends 'My::SchemaBaseClass';\n\n/,
-      qr/\n__PACKAGE__->meta->make_immutable;\n1;(?!\n1;\n)\n.*/,
-    ],
-    Foo => [
-      qr/\nuse Moose;\nuse MooseX::NonMoose;\nuse namespace::autoclean;\nextends 'My::ResultBaseClass';\n\n/,
-      qr/\n__PACKAGE__->meta->make_immutable;\n1;(?!\n1;\n)\n.*/,
-    ],
-    Bar => [
-      qr/\nuse Moose;\nuse MooseX::NonMoose;\nuse namespace::autoclean;\nextends 'My::ResultBaseClass';\n\n/,
-      qr/\n__PACKAGE__->meta->make_immutable;\n1;(?!\n1;\n)\n.*/,
-    ],
-  },
-  neg_regexes => {
-    Foo => [
-      qr/\n__PACKAGE__->meta->make_immutable;\n.*\n__PACKAGE__->meta->make_immutable;/s,
-    ],
-  },
-);
+for my $supply_use_moose (1, 0) {
+  $t->dump_test(
+    classname => 'DBICTest::DumpMore::1',
+    options => {
+      $supply_use_moose ? (use_moose => 1) : (),
+      result_base_class => 'My::ResultBaseClass',
+      schema_base_class => 'My::SchemaBaseClass',
+    },
+    warnings => [
+      qr/Dumping manual schema for DBICTest::DumpMore::1 to directory /,
+      qr/Schema dump completed/,
+    ],
+    regexes => {
+      schema => [
+        qr/\nuse Moose;\nuse MooseX::NonMoose;\nuse namespace::autoclean;\nextends 'My::SchemaBaseClass';\n\n/,
+        qr/\n__PACKAGE__->meta->make_immutable;\n1;(?!\n1;\n)\n.*/,
+      ],
+      Foo => [
+        qr/\nuse Moose;\nuse MooseX::NonMoose;\nuse namespace::autoclean;\nextends 'My::ResultBaseClass';\n\n/,
+        qr/\n__PACKAGE__->meta->make_immutable;\n1;(?!\n1;\n)\n.*/,
+      ],
+      Bar => [
+        qr/\nuse Moose;\nuse MooseX::NonMoose;\nuse namespace::autoclean;\nextends 'My::ResultBaseClass';\n\n/,
+        qr/\n__PACKAGE__->meta->make_immutable;\n1;(?!\n1;\n)\n.*/,
+      ],
+    },
+    neg_regexes => {
+      Foo => [
+        qr/\n__PACKAGE__->meta->make_immutable;\n.*\n__PACKAGE__->meta->make_immutable;/s,
+      ],
+    },
+  );
+}
 
 done_testing;