release 0.07032
[dbsrgits/DBIx-Class-Schema-Loader.git] / lib / DBIx / Class / Schema / Loader / Base.pm
index 120d57f..c93d28d 100644 (file)
@@ -3,6 +3,7 @@ package DBIx::Class::Schema::Loader::Base;
 use strict;
 use warnings;
 use base qw/Class::Accessor::Grouped Class::C3::Componentised/;
+use MRO::Compat;
 use mro 'c3';
 use Carp::Clan qw/^DBIx::Class/;
 use DBIx::Class::Schema::Loader::RelBuilder ();
@@ -28,7 +29,7 @@ use List::MoreUtils qw/all any firstidx uniq/;
 use File::Temp 'tempfile';
 use namespace::clean;
 
-our $VERSION = '0.07014';
+our $VERSION = '0.07032';
 
 __PACKAGE__->mk_group_ro_accessors('simple', qw/
                                 schema
@@ -239,23 +240,20 @@ In general, there is very little difference between v5 and v6 schemas.
 =item v7
 
 This mode is identical to C<v6> mode, except that monikerization of CamelCase
-table names is also done correctly.
+table names is also done better (but best in v8.)
 
-CamelCase column names in case-preserving mode will also be handled correctly
-for relationship name inflection. See L</preserve_case>.
+CamelCase column names in case-preserving mode will also be handled better
+for relationship name inflection (but best in v8.) See L</preserve_case>.
 
 In this mode, CamelCase L</column_accessors> are normalized based on case
 transition instead of just being lowercased, so C<FooId> becomes C<foo_id>.
 
-If you don't have any CamelCase table or column names, you can upgrade without
-breaking any of your code.
-
 =item v8
 
 (EXPERIMENTAL)
 
 The default mode is L</v7>, to get L</v8> mode, you have to specify it in
-L</naming> explictly until C<0.08> comes out.
+L</naming> explicitly until C<0.08> comes out.
 
 L</monikers> and L</column_accessors> are created using
 L<String::ToIdentifier::EN::Unicode> or L<String::ToIdentifier::EN> if
@@ -382,18 +380,55 @@ same database and schema as the table/column whose comment is being retrieved.
 
 =head2 relationship_attrs
 
-Hashref of attributes to pass to each generated relationship, listed
-by type.  Also supports relationship type 'all', containing options to
-pass to all generated relationships.  Attributes set for more specific
-relationship types override those set in 'all'.
+Hashref of attributes to pass to each generated relationship, listed by type.
+Also supports relationship type 'all', containing options to pass to all
+generated relationships.  Attributes set for more specific relationship types
+override those set in 'all', and any attributes specified by this option
+override the introspected attributes of the foreign key if any.
 
 For example:
 
   relationship_attrs => {
-    belongs_to => { is_deferrable => 0 },
+    has_many => { cascade_delete => 1, cascade_copy => 1 },
   },
 
-use this to turn off DEFERRABLE on your foreign key constraints.
+use this to turn L<DBIx::Class> cascades to on on your
+L<has_many|DBIx::Class::Relationship/has_many> relationships, they default to
+off.
+
+Can also be a coderef, for more precise control, in which case the coderef gets
+this hash of parameters:
+
+    rel_name        # the name of the relationship
+    local_source    # the DBIx::Class::ResultSource object for the source the rel is *from*
+    remote_source   # the DBIx::Class::ResultSource object for the source the rel is *to*
+    local_table     # a DBIx::Class::Schema::Loader::Table object for the table of the source the rel is from
+    local_cols      # an arrayref of column names of columns used in the rel in the source it is from
+    remote_table    # a DBIx::Class::Schema::Loader::Table object for the table of the source the rel is to
+    remote_cols     # an arrayref of column names of columns used in the rel in the source it is to
+    attrs           # the attributes that would be set
+
+it should return the new hashref of attributes, or nothing for no changes.
+
+For example:
+
+    relationship_attrs => sub {
+        my %p = @_;
+
+        say "the relationship name is: $p{rel_name}";
+        say "the local class is: ",  $p{local_source}->result_class;
+        say "the remote class is: ", $p{remote_source}->result_class;
+        say "the local table is: ", $p{local_table}->sql_name;
+        say "the rel columns in the local table are: ", (join ", ", @{$p{local_cols}});
+        say "the remote table is: ", $p{remote_table}->sql_name;
+        say "the rel columns in the remote table are: ", (join ", ", @{$p{remote_cols}});
+
+        if ($p{local_table} eq 'dogs' && @{$p{local_cols}} == 1 && $p{local_cols}[0] eq 'name') {
+            $p{attrs}{could_be_snoopy} = 1;
+
+            reutrn $p{attrs};
+        }
+    },
 
 =head2 debug
 
@@ -450,7 +485,7 @@ C<schema>, C<name>
 
 =item * Informix, MSSQL, Sybase ASE
 
-C<database>, C<schema>, C<name>    
+C<database>, C<schema>, C<name>
 
 =back
 
@@ -596,7 +631,7 @@ load certain components for specified Result classes. For example:
                             'InflateColumn::DateTime',
                         ],
   }
-  
+
 You may use this in conjunction with L</components>.
 
 =head2 result_roles
@@ -616,7 +651,7 @@ certain roles for specified Result classes. For example:
                         ],
       RouteChange    => 'YourApp::Role::TripEvent',
   }
-  
+
 You may use this in conjunction with L</result_roles>.
 
 =head2 use_namespaces
@@ -749,7 +784,8 @@ L</naming> = C<v7> or greater is required with this option.
 Set to true to prepend the L</db_schema> to table names for C<<
 __PACKAGE__->table >> calls, and to some other things like Oracle sequences.
 
-This attribute is automatically set to true for multi db_schema configurations.
+This attribute is automatically set to true for multi db_schema configurations,
+unless explicitly set to false by the user.
 
 =head2 use_moose
 
@@ -887,7 +923,7 @@ sub new {
         }
         $self->result_components_map($self->{result_component_map})
     }
-    
+
     if (defined $self->{result_role_map}) {
         if (defined $self->result_roles_map) {
             croak "Specify only one of result_roles_map or result_role_map";
@@ -1054,7 +1090,7 @@ sub new {
 
     if (defined $self->db_schema) {
         if (ref $self->db_schema eq 'ARRAY') {
-            if (@{ $self->db_schema } > 1) {
+            if (@{ $self->db_schema } > 1 && not defined $self->{qualify_objects}) {
                 $self->{qualify_objects} = 1;
             }
             elsif (@{ $self->db_schema } == 0) {
@@ -1062,7 +1098,7 @@ sub new {
             }
         }
         elsif (not ref $self->db_schema) {
-            if ($self->db_schema eq '%') {
+            if ($self->db_schema eq '%' && not defined $self->{qualify_objects}) {
                 $self->{qualify_objects} = 1;
             }
 
@@ -1486,19 +1522,19 @@ sub _load_tables {
 
     # check for moniker clashes
     my $inverse_moniker_idx;
-    foreach my $table (values %{ $self->_tables }) {
-        push @{ $inverse_moniker_idx->{$self->monikers->{$table->sql_name}} }, $table;
+    foreach my $imtable (values %{ $self->_tables }) {
+        push @{ $inverse_moniker_idx->{$self->monikers->{$imtable->sql_name}} }, $imtable;
     }
 
     my @clashes;
     foreach my $moniker (keys %$inverse_moniker_idx) {
-        my $tables = $inverse_moniker_idx->{$moniker};
-        if (@$tables > 1) {
+        my $imtables = $inverse_moniker_idx->{$moniker};
+        if (@$imtables > 1) {
             my $different_databases =
-                $tables->[0]->can('database') && (uniq map $_->database||'', @$tables) > 1;
+                $imtables->[0]->can('database') && (uniq map $_->database||'', @$imtables) > 1;
 
             my $different_schemas =
-                (uniq map $_->schema||'', @$tables) > 1;
+                (uniq map $_->schema||'', @$imtables) > 1;
 
             if ($different_databases || $different_schemas) {
                 my ($use_schema, $use_database) = (1, 0);
@@ -1509,11 +1545,11 @@ sub _load_tables {
                     # If any monikers are in the same database, we have to distinguish by
                     # both schema and database.
                     my %db_counts;
-                    $db_counts{$_}++ for map $_->database, @$tables;
+                    $db_counts{$_}++ for map $_->database, @$imtables;
                     $use_schema = any { $_ > 1 } values %db_counts;
                 }
 
-                delete $self->monikers->{$_->sql_name} for @$tables;
+                foreach my $tbl (@$imtables) { delete $self->monikers->{$tbl->sql_name}; }
 
                 my $moniker_parts = [ @{ $self->moniker_parts } ];
 
@@ -1527,15 +1563,14 @@ sub _load_tables {
 
                 my %new_monikers;
 
-                $new_monikers{$_->sql_name} = $self->_table2moniker($_) for @$tables;
-
-                $self->monikers->{$_} = $new_monikers{$_} for map $_->sql_name, @$tables;
+                foreach my $tbl  (@$imtables)                   { $new_monikers{$tbl->sql_name} = $self->_table2moniker($tbl); }
+                foreach my $name (map $_->sql_name, @$imtables) { $self->monikers->{$name} = $new_monikers{$name}; }
 
                 # check if there are still clashes
                 my %by_moniker;
-                
+
                 while (my ($t, $m) = each %new_monikers) {
-                    push @{ $by_moniker{$m} }, $t; 
+                    push @{ $by_moniker{$m} }, $t;
                 }
 
                 foreach my $m (grep @{ $by_moniker{$_} } > 1, keys %by_moniker) {
@@ -1547,7 +1582,7 @@ sub _load_tables {
             }
             else {
                 push @clashes, sprintf ("tables %s reduced to the same source moniker '%s'",
-                    join (', ', map $_->sql_name, @$tables),
+                    join (', ', map $_->sql_name, @$imtables),
                     $moniker,
                 );
             }
@@ -1562,9 +1597,8 @@ sub _load_tables {
         ;
     }
 
-    $self->_make_src_class($_) for @tables;
-
-    $self->_setup_src_meta($_) for @tables;
+    foreach my $tbl (@tables) { $self->_make_src_class($tbl); }
+    foreach my $tbl (@tables) { $self->_setup_src_meta($tbl); }
 
     if(!$self->skip_relationships) {
         # The relationship loader needs a working schema
@@ -1577,10 +1611,8 @@ sub _load_tables {
         @INC = grep $_ ne $self->dump_directory, @INC;
     }
 
-    $self->_load_roles($_) for @tables;
-
-    $self->_load_external($_)
-        for map { $self->classes->{$_->sql_name} } @tables;
+    foreach my $tbl                                        (@tables) { $self->_load_roles($tbl); }
+    foreach my $tbl (map { $self->classes->{$_->sql_name} } @tables) { $self->_load_external($tbl); }
 
     # Reload without unloading first to preserve any symbols from external
     # packages.
@@ -1606,7 +1638,7 @@ sub _reload_classes {
     $self->_dump_to_dir(map { $self->classes->{$_->sql_name} } @tables);
 
     unshift @INC, $self->dump_directory;
-    
+
     my @to_register;
     my %have_source = map { $_ => $self->schema->source($_) }
         $self->schema->sources;
@@ -1614,7 +1646,7 @@ sub _reload_classes {
     for my $table (@tables) {
         my $moniker = $self->monikers->{$table->sql_name};
         my $class = $self->classes->{$table->sql_name};
-        
+
         {
             no warnings 'redefine';
             local *Class::C3::reinitialize = sub {};  # to speed things up, reinitialized below
@@ -1784,7 +1816,7 @@ sub _dump_to_dir {
     my $result_base_class = $self->result_base_class || 'DBIx::Class::Core';
 
     foreach my $src_class (@classes) {
-        my $src_text = 
+        my $src_text =
               qq|use utf8;\n|
             . qq|package $src_class;\n\n|
             . qq|# Created by DBIx::Class::Schema::Loader\n|
@@ -1839,7 +1871,7 @@ sub _sig_comment {
     my ($self, $version, $ts) = @_;
     return qq|\n\n# Created by DBIx::Class::Schema::Loader|
          . qq| v| . $version
-         . q| @ | . $ts 
+         . q| @ | . $ts
          . qq|\n# DO NOT MODIFY THIS OR ANYTHING ABOVE! md5sum:|;
 }
 
@@ -1984,7 +2016,7 @@ sub _default_moose_custom_content {
     if (not $is_schema) {
         return qq|\n__PACKAGE__->meta->make_immutable;|;
     }
-    
+
     return qq|\n__PACKAGE__->meta->make_immutable(inline_constructor => 0);|;
 }
 
@@ -2552,9 +2584,16 @@ sub _load_relationships {
 
     foreach my $src_class (sort keys %$rel_stmts) {
         # sort by rel name
-        my @src_stmts = map $_->[1],
-            sort { $a->[0] cmp $b->[0] }
-            map [ $_->{args}[0], $_ ], @{ $rel_stmts->{$src_class} };
+        my @src_stmts = map $_->[2],
+            sort {
+                $a->[0] <=> $b->[0]
+                ||
+                $a->[1] cmp $b->[1]
+            } map [
+                ($_->{method} eq 'many_to_many' ? 1 : 0),
+                $_->{args}[0],
+                $_,
+            ], @{ $rel_stmts->{$src_class} };
 
         foreach my $stmt (@src_stmts) {
             $self->_dbic_stmt($src_class,$stmt->{method}, @{$stmt->{args}});
@@ -2683,7 +2722,7 @@ sub _make_pod {
             }
         }
         $self->_pod_cut( $class );
-    } elsif ( $method =~ /^(belongs_to|has_many|might_have)$/ ) {
+    } elsif ( $method =~ /^(?:belongs_to|has_many|might_have)\z/ ) {
         $self->_pod( $class, "=head1 RELATIONS" ) unless $self->{_relations_started} { $class } ;
         my ( $accessor, $rel_class ) = @_;
         $self->_pod( $class, "=head2 $accessor" );
@@ -2691,16 +2730,24 @@ sub _make_pod {
         $self->_pod( $class, "Related object: L<$rel_class>" );
         $self->_pod_cut( $class );
         $self->{_relations_started} { $class } = 1;
+    } elsif ( $method eq 'many_to_many' ) {
+        $self->_pod( $class, "=head1 RELATIONS" ) unless $self->{_relations_started} { $class } ;
+        my ( $accessor, $rel1, $rel2 ) = @_;
+        $self->_pod( $class, "=head2 $accessor" );
+        $self->_pod( $class, 'Type: many_to_many' );
+        $self->_pod( $class, "Composing rels: L</$rel1> -> $rel2" );
+        $self->_pod_cut( $class );
+        $self->{_relations_started} { $class } = 1;
     }
     elsif ($method eq 'add_unique_constraint') {
         $self->_pod($class, '=head1 UNIQUE CONSTRAINTS')
             unless $self->{_uniqs_started}{$class};
-        
+
         my ($name, $cols) = @_;
 
         $self->_pod($class, "=head2 C<$name>");
         $self->_pod($class, '=over 4');
-        
+
         foreach my $col (@$cols) {
             $self->_pod($class, "=item \* L</$col>");
         }
@@ -2713,7 +2760,7 @@ sub _make_pod {
     elsif ($method eq 'set_primary_key') {
         $self->_pod($class, "=head1 PRIMARY KEY");
         $self->_pod($class, '=over 4');
-        
+
         foreach my $col (@_) {
             $self->_pod($class, "=item \* L</$col>");
         }
@@ -2768,7 +2815,7 @@ sub __table_comment {
     if (my $code = $self->can('_table_comment')) {
         return $self->_filter_comment($self->$code(@_));
     }
-    
+
     return '';
 }