do not upgrade non-Moose schemas to use_moose=1 (RT#60558)

diff --git a/Changes b/Changes
index 5deeb43..860c859 100644 (file)
--- a/Changes
+++ b/Changes
@@ -1,6 +1,8 @@
 Revision history for Perl extension Catalyst::Model::DBIC::Schema
 
+        - do not upgrade non-Moose schemas to use_moose=1 (RT#60558)
         - added col_collision_map => 'column_%s' as default loader option
+          (will take effect on release of loader 0.07003)
 
 0.43  Sun Jul 25 01:00:34 UTC 2010
         - add dep for MooseX::NonMoose for the use_moose=1 option

diff --git a/Makefile.PL b/Makefile.PL
index 5b8aba6..bdf9dd5 100644 (file)
--- a/Makefile.PL
+++ b/Makefile.PL
@@ -14,6 +14,7 @@ requires 'namespace::autoclean';
 requires 'Carp::Clan';
 requires 'List::MoreUtils';
 requires 'Tie::IxHash';
+requires 'Try::Tiny';
 
 test_requires 'Test::More' => '0.94';
 test_requires 'Test::Exception';

diff --git a/lib/Catalyst/Helper/Model/DBIC/Schema.pm b/lib/Catalyst/Helper/Model/DBIC/Schema.pm
index 5acd3bb..b386868 100644 (file)
--- a/lib/Catalyst/Helper/Model/DBIC/Schema.pm
+++ b/lib/Catalyst/Helper/Model/DBIC/Schema.pm
@@ -15,6 +15,8 @@ use MooseX::Types::Moose qw/Str HashRef Bool ArrayRef/;
 use Catalyst::Model::DBIC::Schema::Types 'CreateOption';
 use List::MoreUtils 'firstidx';
 use Scalar::Util 'looks_like_number';
+use File::Find 'finddepth';
+use Try::Tiny;
 
 =head1 NAME
 
@@ -143,6 +145,7 @@ has schema_class => (is => 'ro', isa => Str, required => 1);
 has loader_args => (is => 'rw', isa => HashRef);
 has connect_info => (is => 'rw', isa => HashRef);
 has old_schema => (is => 'rw', isa => Bool, lazy_build => 1);
+has is_moose_schema => (is => 'rw', isa => Bool, lazy_build => 1);
 has components => (is => 'rw', isa => ArrayRef);
 
 =head1 METHODS
@@ -265,7 +268,7 @@ sub _parse_loader_args {
 
     %result = (
         relationships => 1,
-        use_moose => 1,
+        use_moose => $self->is_moose_schema ? 1 : 0,
         col_collision_map => 'column_%s',
         (!$self->old_schema ? (
                 use_namespaces => 1
@@ -399,6 +402,35 @@ sub _build_old_schema {
     0;
 }
 
+sub _build_is_moose_schema {
+    my $self = shift;
+
+    my @schema_parts = split '::', $self->schema_class;
+    my $schema_dir =
+        File::Spec->catfile($self->helper->{base}, 'lib', @schema_parts);
+
+    # assume yes for new schemas
+    return 1 if not -d $schema_dir;
+
+    my $uses_moose = 1;
+
+    try {
+        finddepth(sub {
+            open my $fh, '<', $File::Find::name
+                or die "Could not open $File::Find::name: $!";
+
+            my $code = do { local $/; <$fh> };
+            close $fh;
+
+            $uses_moose = 0 if $code !~ /\nuse Moose;\n/;
+
+            die;
+        }, $schema_dir);
+    };
+
+    return $uses_moose;
+}
+
 sub _data_struct_to_string {
     my ($self, $data) = @_;
 

diff --git a/t/05testapp.t b/t/05testapp.t
index c0fad1f..f8f133a 100644 (file)
--- a/t/05testapp.t
+++ b/t/05testapp.t
@@ -53,7 +53,7 @@ close $sql;
 foreach my $tparam (@$test_params) {
    my ($model, $helper, @args) = @$tparam;
 
-   unlink for glob(File::Spec->catfile($schema_dir, 'Result', '*'));
+   cleanup_schema();
 
    system($^X, "-I$blib_dir", $creator, 'model', $model, $helper, $model, @args);
 
@@ -63,14 +63,53 @@ foreach my $tparam (@$test_params) {
    ok($compile_rv == 0, "perl -c $model_path");
 
    if (grep /create=static/, @args) {
-      my $glob = File::Spec->catfile($schema_dir, 'Result', '*');
-      my $tables =()= glob($glob);
+      my @result_files = result_files();
 
       if (grep /constraint/, @args) {
-         is $tables, 1, 'constraint works';
+         is scalar @result_files, 1, 'constraint works';
       } else {
-         is $tables, 2, 'correct number of tables';
+         is scalar @result_files, 2, 'correct number of tables';
       }
+
+      for my $file (@result_files) {
+         my $code = code_for($file);
+
+         like $code, qr/use Moose;\n/, 'use_moose enabled';
+         like $code, qr/__PACKAGE__->meta->make_immutable;\n/, 'use_moose enabled';
+      }
+   }
+}
+
+# Test that use_moose=1 is not applied to existing non-moose schemas (RT#60558)
+{
+   cleanup_schema();
+
+   system($^X, "-I$blib_dir", $creator, 'model',
+      'TestSchemaDSN', 'DBIC::Schema', 'TestSchemaDSN',
+      'create=static', 'use_moose=0', 'dbi:SQLite:testdb.db'
+   );
+
+   my @result_files = result_files();
+
+   for my $file (@result_files) {
+      my $code = code_for($file);
+
+      unlike $code, qr/use Moose;\n/, 'non use_moose=1 schema';
+      unlike $code, qr/__PACKAGE__->meta->make_immutable;\n/, 'non use_moose=1 schema';
+   }
+
+   system($^X, "-I$blib_dir", $creator, 'model',
+      'TestSchemaDSN', 'DBIC::Schema', 'TestSchemaDSN',
+      'create=static', 'dbi:SQLite:testdb.db'
+   );
+
+   for my $file (@result_files) {
+      my $code = code_for($file);
+
+      unlike $code, qr/use Moose;\n/,
+         'non use_moose=1 schema not upgraded to use_moose=1';
+      unlike $code, qr/__PACKAGE__->meta->make_immutable;\n/,
+         'non use_moose=1 schema not upgraded to use_moose=1';
    }
 }
 
@@ -82,9 +121,33 @@ sub rm_rf {
     else { unlink $name or die "Cannot unlink $name: $!" }
 }
 
+sub cleanup_schema {
+   return unless -d $schema_dir;
+   finddepth(\&rm_rf, $schema_dir);
+   unlink "${schema_dir}.pm";
+}
+
+sub code_for {
+   my $file = shift;
+
+   open my $fh, '<', $file;
+   my $code = do { local $/; <$fh> };
+   close $fh;
+
+   return $code;
+}
+
+sub result_files {
+   my $glob = File::Spec->catfile($schema_dir, 'Result', '*');
+
+   return glob($glob);
+}
+
 END {
     if ($ENV{C_M_DBIC_SCHEMA_TESTAPP}) {
         chdir($test_dir);
         finddepth(\&rm_rf, $cat_dir);
     }
 }
+
+# vim:sts=3 sw=3 et tw=80: