* use $^X instead of assuming /usr/bin/perl

[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 a78ba9e..f7e1051 100644 (file)
--- a/lib/DBIx/Class/Schema/Loader/Base.pm
+++ b/lib/DBIx/Class/Schema/Loader/Base.pm
@@ -17,7 +17,7 @@ use File::Temp qw//;
 use Class::Unload;
 require DBIx::Class;
 
-our $VERSION = '0.04999_05';
+our $VERSION = '0.04999_06';
 
 __PACKAGE__->mk_ro_accessors(qw/
                                 schema
@@ -42,6 +42,8 @@ __PACKAGE__->mk_ro_accessors(qw/
                                 result_namespace
                                 resultset_namespace
                                 default_resultset_class
+                                schema_base_class
+                                result_base_class
 
                                 db_schema
                                 _tables
@@ -123,6 +125,14 @@ L<Lingua::EN::Inflect::Number/to_PL>.
 As L</inflect_plural> above, but for singularizing relationship names.
 Default behavior is to utilize L<Lingua::EN::Inflect::Number/to_S>.
 
+=head2 schema_base_class
+
+Base class for your schema classes. Defaults to 'DBIx::Class::Schema'.
+
+=head2 result_base_class
+
+Base class for your table classes (aka result classes). Defaults to 'DBIx::Class'.
+
 =head2 additional_base_classes
 
 List of additional base classes all of your table classes will use.
@@ -408,17 +418,25 @@ sub _reload_classes {
     my ($self, @tables) = @_;
 
     $self->_dump_to_dir(map { $self->classes->{$_} } @tables);
+
+    unshift @INC, $self->dump_directory;
     
     for my $table (@tables) {
         my $moniker = $self->monikers->{$table};
         my $class = $self->classes->{$table};
-
-        if ( Class::Unload->unload( $class ) ) {
-            my $resultset_class = ref $self->schema->resultset($moniker);
-            Class::Unload->unload( $resultset_class )
-                  if $resultset_class ne 'DBIx::Class::ResultSet';
+        
+        {
+            no warnings 'redefine';
+            local *Class::C3::reinitialize = sub {};
+            use warnings;
+
+            if ( Class::Unload->unload( $class ) ) {
+                my $resultset_class = ref $self->schema->resultset($moniker);
+                Class::Unload->unload( $resultset_class )
+                      if $resultset_class ne 'DBIx::Class::ResultSet';
+            }
+            $class->require or die "Can't load $class: $@";
         }
-        $class->require or die "Can't load $class: $@";
 
         $self->schema_class->register_class($moniker, $class);
         $self->schema->register_class($moniker, $class)
@@ -453,19 +471,18 @@ sub _ensure_dump_subdirs {
 sub _dump_to_dir {
     my ($self, @classes) = @_;
 
-    my $target_dir = $self->dump_directory;
-
     my $schema_class = $self->schema_class;
+    my $schema_base_class = $self->schema_base_class || 'DBIx::Class::Schema';
 
+    my $target_dir = $self->dump_directory;
     warn "Dumping manual schema for $schema_class to directory $target_dir ...\n"
         unless $self->{dynamic} or $self->{quiet};
 
     my $schema_text =
           qq|package $schema_class;\n\n|
         . qq|use strict;\nuse warnings;\n\n|
-        . qq|use base 'DBIx::Class::Schema';\n\n|;
+        . qq|use base '$schema_base_class';\n\n|;
 
-    
     if ($self->use_namespaces) {
         $schema_text .= qq|__PACKAGE__->load_namespaces|;
         my $namespace_options;
@@ -481,23 +498,23 @@ sub _dump_to_dir {
     }
     else {
         $schema_text .= qq|__PACKAGE__->load_classes;\n|;
-
     }
 
     $self->_write_classfile($schema_class, $schema_text);
 
+    my $result_base_class = $self->result_base_class || 'DBIx::Class';
+
     foreach my $src_class (@classes) {
         my $src_text = 
               qq|package $src_class;\n\n|
             . qq|use strict;\nuse warnings;\n\n|
-            . qq|use base 'DBIx::Class';\n\n|;
+            . qq|use base '$result_base_class';\n\n|;
 
         $self->_write_classfile($src_class, $src_text);
     }
 
     warn "Schema dump completed.\n" unless $self->{dynamic} or $self->{quiet};
 
-    unshift @INC, $target_dir;
 }
 
 sub _write_classfile {
@@ -513,7 +530,6 @@ sub _write_classfile {
     }    
 
     my $custom_content = $self->_get_custom_content($class, $filename);
-
     $custom_content ||= qq|\n\n# You can replace this text with custom|
         . qq| content, and it will be preserved on regeneration|
         . qq|\n1;\n|;
@@ -536,10 +552,11 @@ sub _write_classfile {
     print $fh qq|$_\n|
         for @{$self->{_ext_storage}->{$class} || []};
 
+    # Write out any custom content the user has added
     print $fh $custom_content;
 
     close($fh)
-        or croak "Cannot close '$filename': $!";
+        or croak "Error closing '$filename': $!";
 }
 
 sub _get_custom_content {
@@ -666,12 +683,20 @@ sub _setup_src_meta {
         );
     }
 
+    my %uniq_tag; # used to eliminate duplicate uniqs
+
     my $pks = $self->_table_pk_info($table) || [];
     @$pks ? $self->_dbic_stmt($table_class,'set_primary_key',@$pks)
           : carp("$table has no primary key");
+    $uniq_tag{ join("\0", @$pks) }++ if @$pks; # pk is a uniq
 
     my $uniqs = $self->_table_uniq_info($table) || [];
-    $self->_dbic_stmt($table_class,'add_unique_constraint',@$_) for (@$uniqs);
+    for (@$uniqs) {
+        my ($name, $cols) = @$_;
+        next if $uniq_tag{ join("\0", @$cols) }++; # skip duplicates
+        $self->_dbic_stmt($table_class,'add_unique_constraint', $name, $cols);
+    }
+
 }
 
 =head2 tables