release 0.07026
[dbsrgits/DBIx-Class-Schema-Loader.git] / lib / DBIx / Class / Schema / Loader / Base.pm
index c94c09d..4e43d0c 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 ();
@@ -24,12 +25,11 @@ use DBIx::Class::Schema::Loader::Optional::Dependencies ();
 use Try::Tiny;
 use DBIx::Class ();
 use Encode qw/encode decode/;
-use List::MoreUtils qw/all firstidx/;
-use IPC::Open2;
-use Symbol 'gensym';
+use List::MoreUtils qw/all any firstidx uniq/;
+use File::Temp 'tempfile';
 use namespace::clean;
 
-our $VERSION = '0.07010';
+our $VERSION = '0.07026';
 
 __PACKAGE__->mk_group_ro_accessors('simple', qw/
                                 schema
@@ -240,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
@@ -416,8 +413,12 @@ keys and arrays of owners as values, set to the value:
 
 for all owners in all databases.
 
-You may need to control naming of monikers with L</moniker_parts> if you have
-name clashes for tables in different schemas/databases.
+Name clashes resulting from the same table name in different databases/schemas
+will be resolved automatically by prefixing the moniker with the database
+and/or schema.
+
+To prefix/suffix all monikers with the database and/or schema, see
+L</moniker_parts>.
 
 =head2 moniker_parts
 
@@ -447,7 +448,7 @@ C<schema>, C<name>
 
 =item * Informix, MSSQL, Sybase ASE
 
-C<database>, C<schema>, C<name>    
+C<database>, C<schema>, C<name>
 
 =back
 
@@ -461,12 +462,12 @@ Exclude tables matching regex.  Best specified as a qr// regex.
 
 =head2 moniker_map
 
-Overrides the default table name to moniker translation.  Can be either
-a hashref of table keys and moniker values, or a coderef for a translator
-function taking a single scalar table name argument and returning
-a scalar moniker.  If the hash entry does not exist, or the function
-returns a false value, the code falls back to default behavior
-for that table name.
+Overrides the default table name to moniker translation.  Can be either a
+hashref of table keys and moniker values, or a coderef for a translator
+function taking a L<table object|DBIx::Class::Schema::Loader::Table> argument
+(which stringifies to the unqualified table name) and returning a scalar
+moniker.  If the hash entry does not exist, or the function returns a false
+value, the code falls back to default behavior for that table name.
 
 The default behavior is to split on case transition and non-alphanumeric
 boundaries, singularize the resulting phrase, then join the titlecased words
@@ -490,11 +491,14 @@ passed, the code is called with arguments of
    {
       table_class     => name of the DBIC class we are building,
       table_moniker   => calculated moniker for this table (after moniker_map if present),
-      table_name      => name of the database table,
+      table           => table object of interface DBIx::Class::Schema::Loader::Table,
       full_table_name => schema-qualified name of the database table (RDBMS specific),
       schema_class    => name of the schema class we are building,
       column_info     => hashref of column info (data_type, is_nullable, etc),
-    }
+   }
+
+the L<table object|DBIx::Class::Schema::Loader::Table> stringifies to the
+unqualified table name.
 
 =head2 rel_name_map
 
@@ -590,7 +594,7 @@ load certain components for specified Result classes. For example:
                             'InflateColumn::DateTime',
                         ],
   }
-  
+
 You may use this in conjunction with L</components>.
 
 =head2 result_roles
@@ -610,7 +614,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
@@ -685,12 +689,13 @@ L<column_info|DBIx::Class::ResultSource/column_info> for a column.
 
 Must be a coderef that returns a hashref with the extra attributes.
 
-Receives the table name, column name and column_info.
+Receives the L<table object|DBIx::Class::Schema::Loader::Table> (which
+stringifies to the unqualified table name), column name and column_info.
 
 For example:
 
   custom_column_info => sub {
-      my ($table_name, $column_name, $column_info) = @_;
+      my ($table, $column_name, $column_info) = @_;
 
       if ($column_name eq 'dog' && $column_info->{default_value} eq 'snoopy') {
           return { is_snoopy => 1 };
@@ -742,6 +747,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.
+
 =head2 use_moose
 
 Creates Schema and Result classes that use L<Moose>, L<MooseX::NonMoose> and
@@ -878,7 +885,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";
@@ -1469,40 +1476,91 @@ sub _relbuilder {
 sub _load_tables {
     my ($self, @tables) = @_;
 
-    # Save the new tables to the tables list
+    # Save the new tables to the tables list and compute monikers
     foreach (@tables) {
-        $self->_tables->{$_->sql_name} = $_;
+        $self->_tables->{$_->sql_name}  = $_;
+        $self->monikers->{$_->sql_name} = $self->_table2moniker($_);
     }
 
-    $self->_make_src_class($_) for @tables;
-
-    # sanity-check for moniker clashes
+    # 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) {
-        push @clashes, sprintf ("tables %s reduced to the same source moniker '%s'",
-          join (', ', map $_->sql_name, @$tables),
-          $moniker,
-        );
-      }
+        my $imtables = $inverse_moniker_idx->{$moniker};
+        if (@$imtables > 1) {
+            my $different_databases =
+                $imtables->[0]->can('database') && (uniq map $_->database||'', @$imtables) > 1;
+
+            my $different_schemas =
+                (uniq map $_->schema||'', @$imtables) > 1;
+
+            if ($different_databases || $different_schemas) {
+                my ($use_schema, $use_database) = (1, 0);
+
+                if ($different_databases) {
+                    $use_database = 1;
+
+                    # 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, @$imtables;
+                    $use_schema = any { $_ > 1 } values %db_counts;
+                }
+
+                foreach my $tbl (@$imtables) { delete $self->monikers->{$tbl->sql_name}; }
+
+                my $moniker_parts = [ @{ $self->moniker_parts } ];
+
+                my $have_schema   = 1 if any { $_ eq 'schema'   } @{ $self->moniker_parts };
+                my $have_database = 1 if any { $_ eq 'database' } @{ $self->moniker_parts };
+
+                unshift @$moniker_parts, 'schema'   if $use_schema   && !$have_schema;
+                unshift @$moniker_parts, 'database' if $use_database && !$have_database;
+
+                local $self->{moniker_parts} = $moniker_parts;
+
+                my %new_monikers;
+
+                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;
+                }
+
+                foreach my $m (grep @{ $by_moniker{$_} } > 1, keys %by_moniker) {
+                    push @clashes, sprintf ("tried disambiguating by moniker_parts, but tables %s still reduced to the same source moniker '%s'",
+                        join (', ', @{ $by_moniker{$m} }),
+                        $m,
+                    );
+                }
+            }
+            else {
+                push @clashes, sprintf ("tables %s reduced to the same source moniker '%s'",
+                    join (', ', map $_->sql_name, @$imtables),
+                    $moniker,
+                );
+            }
+        }
     }
 
     if (@clashes) {
-      die   'Unable to load schema - chosen moniker/class naming style results in moniker clashes. '
-          . 'In multi db_schema configurations you may need to set moniker_parts, '
-          . 'otherwise change the naming style, or supply an explicit moniker_map: '
-          . join ('; ', @clashes)
-          . "\n"
-      ;
+        die 'Unable to load schema - chosen moniker/class naming style results in moniker clashes. '
+        . 'Change the naming style, or supply an explicit moniker_map: '
+        . join ('; ', @clashes)
+        . "\n"
+        ;
     }
 
-    $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
@@ -1515,10 +1573,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.
@@ -1544,7 +1600,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;
@@ -1552,7 +1608,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
@@ -1722,7 +1778,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|
@@ -1777,7 +1833,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:|;
 }
 
@@ -1803,17 +1859,13 @@ sub _write_classfile {
 
     my $custom_content = $old_custom || '';
 
-    # prepend extra custom content from a *renamed* class (singularization effect)
+    # Use custom content from a renamed class, the class names in it are
+    # rewritten below.
     if (my $renamed_class = $self->_upgrading_classes->{$class}) {
         my $old_filename = $self->_get_dump_filename($renamed_class);
 
         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;
+            $custom_content = ($self->_parse_generated_file ($old_filename))[4];
 
             unlink $old_filename;
         }
@@ -1858,23 +1910,26 @@ sub _write_classfile {
             );
         }
         else {
-            my ($out, $in) = (gensym, gensym);
-
-            my $pid = open2($out, $in, $filter)
-                or croak "Could not open pipe to $filter: $!";
+            my ($fh, $temp_file) = tempfile();
 
-            print $in $text;
+            binmode $fh, ':encoding(UTF-8)';
+            print $fh $text;
+            close $fh;
 
-            close $in;
+            open my $out, qq{$filter < "$temp_file"|}
+                or croak "Could not open pipe to $filter: $!";
 
             $text = decode('UTF-8', do { local $/; <$out> });
 
             $text =~ s/$CR?$LF/\n/g;
 
-            waitpid $pid, 0;
+            close $out;
 
             my $exit_code = $? >> 8;
 
+            unlink $temp_file
+                or croak "Could not remove temporary file '$temp_file': $!";
+
             if ($exit_code != 0) {
                 croak "filter '$filter' exited non-zero: $exit_code";
             }
@@ -1923,7 +1978,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);|;
 }
 
@@ -2039,7 +2094,7 @@ sub _make_src_class {
     my $schema       = $self->schema;
     my $schema_class = $self->schema_class;
 
-    my $table_moniker = $self->_table2moniker($table);
+    my $table_moniker = $self->monikers->{$table->sql_name};
     my @result_namespace = ($schema_class);
     if ($self->use_namespaces) {
         my $result_namespace = $self->result_namespace || 'Result';
@@ -2084,7 +2139,6 @@ sub _make_src_class {
     }
 
     $self->classes->{$table->sql_name}  = $table_class;
-    $self->monikers->{$table->sql_name} = $table_moniker;
     $self->moniker_to_table->{$table_moniker} = $table;
     $self->class_to_table->{$table_class} = $table;
 
@@ -2492,9 +2546,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}});
@@ -2623,7 +2684,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" );
@@ -2631,16 +2692,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>");
         }
@@ -2653,7 +2722,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>");
         }
@@ -2708,7 +2777,7 @@ sub __table_comment {
     if (my $code = $self->can('_table_comment')) {
         return $self->_filter_comment($self->$code(@_));
     }
-    
+
     return '';
 }
 
@@ -2818,7 +2887,7 @@ If you use the loader on a database with table and column names in a language
 other than English, you will want to turn off the English language specific
 heuristics.
 
-To do so, use something like this in your laoder options:
+To do so, use something like this in your loader options:
 
     naming           => { monikers => 'v4' },
     inflect_singular => sub { "$_[0]_rel" },
@@ -2853,7 +2922,7 @@ You can also control the renaming with the L</rel_collision_map> option.
 
 =head1 SEE ALSO
 
-L<DBIx::Class::Schema::Loader>
+L<DBIx::Class::Schema::Loader>, L<dbicdump>
 
 =head1 AUTHOR