Release 0.07037
[dbsrgits/DBIx-Class-Schema-Loader.git] / lib / DBIx / Class / Schema / Loader / Base.pm
index ee67a54..1994637 100644 (file)
@@ -20,7 +20,7 @@ use File::Temp ();
 use Class::Unload;
 use Class::Inspector ();
 use Scalar::Util 'looks_like_number';
-use DBIx::Class::Schema::Loader::Utils qw/split_name dumper_squashed eval_package_without_redefine_warnings class_path slurp_file/;
+use DBIx::Class::Schema::Loader::Utils qw/split_name dumper_squashed eval_package_without_redefine_warnings class_path slurp_file sigwarn_silencer/;
 use DBIx::Class::Schema::Loader::Optional::Dependencies ();
 use Try::Tiny;
 use DBIx::Class ();
@@ -29,7 +29,7 @@ use List::MoreUtils qw/all any firstidx uniq/;
 use File::Temp 'tempfile';
 use namespace::clean;
 
-our $VERSION = '0.07029';
+our $VERSION = '0.07037';
 
 __PACKAGE__->mk_group_ro_accessors('simple', qw/
                                 schema
@@ -109,6 +109,8 @@ __PACKAGE__->mk_group_accessors('simple', qw/
                                 db_schema
                                 qualify_objects
                                 moniker_parts
+                                moniker_part_separator
+                                moniker_part_map
 /);
 
 my $CURRENT_V = 'v7';
@@ -380,18 +382,103 @@ 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 },
+    might_have => { 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> and
+L<might_have|DBIx::Class::Relationship/might_have> relationships, they default
+to off.
+
+Can also be a coderef, for more precise control, in which case the coderef gets
+this hash of parameters (as a list:)
+
+    rel_name        # the name of the relationship
+    rel_type        # the type of the relationship: 'belongs_to', 'has_many' or 'might_have'
+    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 relationship is a: $p{rel_type}";
+        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};
+        }
+    },
+
+These are the default attributes:
+
+    has_many => {
+        cascade_delete => 0,
+        cascade_copy   => 0,
+    },
+    might_have => {
+        cascade_delete => 0,
+        cascade_copy   => 0,
+    },
+    belongs_to => {
+        on_delete => 'CASCADE',
+        on_update => 'CASCADE',
+        is_deferrable => 1,
+    },
+
+For L<belongs_to|DBIx::Class::Relationship/belongs_to> relationships, these
+defaults are overridden by the attributes introspected from the foreign key in
+the database, if this information is available (and the driver is capable of
+retrieving it.)
+
+This information overrides the defaults mentioned above, and is then itself
+overridden by the user's L</relationship_attrs> for C<belongs_to> if any are
+specified.
+
+In general, for most databases, for a plain foreign key with no rules, the
+values for a L<belongs_to|DBIx::Class::Relationship/belongs_to> relationship
+will be:
+
+    on_delete     => 'NO ACTION',
+    on_update     => 'NO ACTION',
+    is_deferrable => 0,
+
+In the cases where an attribute is not supported by the DB, a value matching
+the actual behavior is used, for example Oracle does not support C<ON UPDATE>
+rules, so C<on_update> is set to C<NO ACTION>. This is done so that the
+behavior of the schema is preserved when cross deploying to a different RDBMS
+such as SQLite for testing.
+
+In the cases where the DB does not support C<DEFERRABLE> foreign keys, the
+value is set to C<1> if L<DBIx::Class> has a working C<<
+$storage->with_deferred_fk_checks >>. This is done so that the same
+L<DBIx::Class> code can be used, and cross deployed from and to such databases.
 
 =head2 debug
 
@@ -435,6 +522,7 @@ the table.
 The L</moniker_parts> option is an arrayref of methods on the table class
 corresponding to parts of the fully qualified table name, defaulting to
 C<['name']>, in the order those parts are used to create the moniker name.
+The parts are joined together using L</moniker_part_separator>.
 
 The C<'name'> entry B<must> be present.
 
@@ -452,21 +540,72 @@ C<database>, C<schema>, C<name>
 
 =back
 
+=head2 moniker_part_separator
+
+String used to join L</moniker_parts> when creating the moniker.
+Defaults to the empty string. Use C<::> to get a separate namespace per
+database and/or schema.
+
 =head2 constraint
 
-Only load tables matching regex.  Best specified as a qr// regex.
+Only load matching tables.
 
 =head2 exclude
 
-Exclude tables matching regex.  Best specified as a qr// regex.
+Exclude matching tables.
+
+These can be specified either as a regex (preferrably on the C<qr//>
+form), or as an arrayref of arrayrefs.  Regexes are matched against
+the (unqualified) table name, while arrayrefs are matched according to
+L</moniker_parts>.
+
+For example:
+
+    db_schema => [qw(some_schema other_schema)],
+    moniker_parts => [qw(schema name)],
+    constraint => [
+        [ qr/\Asome_schema\z/ => qr/\A(?:foo|bar)\z/ ],
+        [ qr/\Aother_schema\z/ => qr/\Abaz\z/ ],
+    ],
+
+In this case only the tables C<foo> and C<bar> in C<some_schema> and
+C<baz> in C<other_schema> will be dumped.
 
 =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 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
+Overrides the default table name to moniker translation. Either
+
+=over
+
+=item *
+
+a nested hashref, which will be traversed according to L</moniker_parts>
+
+For example:
+
+    moniker_parts => [qw(schema name)],
+    moniker_map => {
+        foo => {
+            bar  => "FooishBar",
+        },
+    },
+
+In which case the table C<bar> in the C<foo> schema would get the moniker
+C<FooishBar>.
+
+=item *
+
+a hashref of unqualified table name keys and moniker values
+
+=item *
+
+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
+
+=back
+
+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
@@ -481,6 +620,25 @@ together. Examples:
     stations_visited | StationVisited
     routeChange      | RouteChange
 
+=head2 moniker_part_map
+
+Map for overriding the monikerization of individual L</moniker_parts>.
+The keys are the moniker part to override, the value is either a
+hashref of coderef for mapping the corresponding part of the
+moniker. If a coderef is used, it gets called with the moniker part
+and the hash key the code ref was found under.
+
+For example:
+
+    moniker_part_map => {
+        schema => sub { ... },
+    },
+
+Given the table C<foo.bar>, the code ref would be called with the
+arguments C<foo> and C<schema>.
+
+L</moniker_map> takes precedence over this.
+
 =head2 col_accessor_map
 
 Same as moniker_map, but for column accessor names.  If a coderef is
@@ -533,6 +691,10 @@ If it is a coderef, the argument passed will be a hashref of this form:
         remote_class   => name of the DBIC class we are related to,
         remote_moniker => moniker of the DBIC class we are related to,
         remote_columns => columns in the other table in the relationship,
+        # for type => "many_to_many" only:
+        link_class     => name of the DBIC class for the link table
+        link_moniker   => moniker of the DBIC class for the link table
+        link_rel_name  => name of the relationship to the link table
     }
 
 DBICSL will try to use the value returned as the relationship name.
@@ -833,7 +995,7 @@ L<DBIx::Class::Schema::Loader>.
 
 =cut
 
-# ensure that a peice of object data is a valid arrayref, creating
+# ensure that a piece of object data is a valid arrayref, creating
 # an empty one or encapsulating whatever's there.
 sub _ensure_arrayref {
     my $self = shift;
@@ -1084,6 +1246,13 @@ sub new {
         }
     }
 
+    if (not defined $self->moniker_part_separator) {
+        $self->moniker_part_separator('');
+    }
+    if (not defined $self->moniker_part_map) {
+        $self->moniker_part_map({}),
+    }
+
     return $self;
 }
 
@@ -1252,7 +1421,7 @@ sub _validate_classes {
 
     foreach my $c (@classes) {
         # components default to being under the DBIx::Class namespace unless they
-        # are preceeded with a '+'
+        # are preceded with a '+'
         if ( $key =~ m/component/ && $c !~ s/^\+// ) {
             $c = 'DBIx::Class::' . $c;
         }
@@ -1275,8 +1444,10 @@ sub _find_file_in_inc {
 
     foreach my $prefix (@INC) {
         my $fullpath = File::Spec->catfile($prefix, $file);
+        # abs_path pure-perl fallback warns for non-existent files
+        local $SIG{__WARN__} = sigwarn_silencer(qr/^stat\(.*\Q$file\E\)/);
         return $fullpath if -f $fullpath
-            # abs_path throws on Windows for nonexistant files
+            # abs_path throws on Windows for nonexistent files
             and (try { Cwd::abs_path($fullpath) }) ne
                ((try { Cwd::abs_path(File::Spec->catfile($self->dump_directory, $file)) }) || '');
     }
@@ -1516,8 +1687,8 @@ sub _load_tables {
 
                 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 };
+                my $have_schema   = any { $_ eq 'schema'   } @{ $self->moniker_parts };
+                my $have_database = any { $_ eq 'database' } @{ $self->moniker_parts };
 
                 unshift @$moniker_parts, 'schema'   if $use_schema   && !$have_schema;
                 unshift @$moniker_parts, 'database' if $use_database && !$have_database;
@@ -2254,7 +2425,23 @@ sub _run_user_map {
     my $default_ident = $default_code->( $ident, @extra );
     my $new_ident;
     if( $map && ref $map eq 'HASH' ) {
-        $new_ident = $map->{ $ident };
+        if (my @parts = try{ @{ $ident } }) {
+            my $part_map = $map;
+            while (@parts) {
+                my $part = shift @parts;
+                last unless exists $part_map->{ $part };
+                if ( !ref $part_map->{ $part } && !@parts ) {
+                    $new_ident = $part_map->{ $part };
+                    last;
+                }
+                elsif ( ref $part_map->{ $part } eq 'HASH' ) {
+                    $part_map = $part_map->{ $part };
+                }
+            }
+        }
+        if( !$new_ident && !ref $map->{ $ident } ) {
+            $new_ident = $map->{ $ident };
+        }
     }
     elsif( $map && ref $map eq 'CODE' ) {
         $new_ident = $map->( $ident, $default_ident, @extra );
@@ -2304,6 +2491,11 @@ sub _make_column_accessor_name {
     return $accessor;
 }
 
+sub _table_is_view {
+    #my ($self, $table) = @_;
+    return 0;
+}
+
 # Set up metadata (cols, pks, etc)
 sub _setup_src_meta {
     my ($self, $table) = @_;
@@ -2314,6 +2506,9 @@ sub _setup_src_meta {
     my $table_class   = $self->classes->{$table->sql_name};
     my $table_moniker = $self->monikers->{$table->sql_name};
 
+    $self->_dbic_stmt($table_class, 'table_class', 'DBIx::Class::ResultSource::View')
+        if $self->_table_is_view($table);
+
     $self->_dbic_stmt($table_class, 'table', $table->dbic_name);
 
     my $cols     = $self->_table_columns($table);
@@ -2326,7 +2521,8 @@ sub _setup_src_meta {
         my $context = {
             table_class     => $table_class,
             table_moniker   => $table_moniker,
-            table_name      => $table,
+            table_name      => $table, # bugwards compatibility, RT#84050
+            table           => $table,
             full_table_name => $table->dbic_name,
             schema_class    => $schema_class,
             column_info     => $info,
@@ -2470,7 +2666,8 @@ sub _default_table2moniker {
 
     my $v = $self->_get_naming_v('monikers');
 
-    my @name_parts = map $table->$_, @{ $self->moniker_parts };
+    my @moniker_parts = @{ $self->moniker_parts };
+    my @name_parts = map $table->$_, @moniker_parts;
 
     my $name_idx = firstidx { $_ eq 'name' } @{ $self->moniker_parts };
 
@@ -2479,6 +2676,16 @@ sub _default_table2moniker {
     foreach my $i (0 .. $#name_parts) {
         my $part = $name_parts[$i];
 
+        my $moniker_part = $self->_run_user_map(
+            $self->moniker_part_map->{$moniker_parts[$i]},
+            sub { '' },
+            $part, $moniker_parts[$i],
+        );
+        if (length $moniker_part) {
+            push @all_parts, $moniker_part;
+            next;
+        }
+
         if ($i != $name_idx || $v >= 8) {
             $part = $self->_to_identifier('monikers', $part, '_', 1);
         }
@@ -2506,10 +2713,10 @@ sub _default_table2moniker {
             @part_parts = split /\s+/, $inflected;
         }
 
-        push @all_parts, map ucfirst, @part_parts;
+        push @all_parts, join '', map ucfirst, @part_parts;
     }
 
-    return join '', @all_parts;
+    return join $self->moniker_part_separator, @all_parts;
 }
 
 sub _table2moniker {