Add option to allow extra columns in many_to_many link tables
[dbsrgits/DBIx-Class-Schema-Loader.git] / lib / DBIx / Class / Schema / Loader / Base.pm
index a133812..3cd33f1 100644 (file)
@@ -20,16 +20,16 @@ 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 firstidx uniq/;
 use DBIx::Class::Schema::Loader::Optional::Dependencies ();
 use Try::Tiny;
 use DBIx::Class ();
 use Encode qw/encode decode/;
-use List::MoreUtils qw/all any firstidx uniq/;
+use List::Util qw/all any none/;
 use File::Temp 'tempfile';
 use namespace::clean;
 
-our $VERSION = '0.07036';
+our $VERSION = '0.07042';
 
 __PACKAGE__->mk_group_ro_accessors('simple', qw/
                                 schema
@@ -61,6 +61,10 @@ __PACKAGE__->mk_group_ro_accessors('simple', qw/
                                 use_moose
                                 only_autoclean
                                 overwrite_modifications
+                                dry_run
+                                generated_classes
+                                omit_version
+                                omit_timestamp
 
                                 relationship_attrs
 
@@ -80,6 +84,7 @@ __PACKAGE__->mk_group_ro_accessors('simple', qw/
                                 moniker_to_table
                                 uniq_to_primary
                                 quiet
+                                allow_extra_m2m_cols
 /);
 
 
@@ -109,6 +114,8 @@ __PACKAGE__->mk_group_accessors('simple', qw/
                                 db_schema
                                 qualify_objects
                                 moniker_parts
+                                moniker_part_separator
+                                moniker_part_map
 /);
 
 my $CURRENT_V = 'v7';
@@ -204,7 +211,7 @@ How to name column accessors in Result classes.
 =item force_ascii
 
 For L</v8> mode and later, uses L<String::ToIdentifier::EN> instead of
-L<String::ToIdentifier::EM::Unicode> to force monikers and other identifiers to
+L<String::ToIdentifier::EN::Unicode> to force monikers and other identifiers to
 ASCII.
 
 =back
@@ -303,6 +310,11 @@ If true, will not print the usual C<Dumping manual schema ... Schema dump
 completed.> messages. Does not affect warnings (except for warnings related to
 L</really_erase_my_files>.)
 
+=head2 dry_run
+
+If true, don't actually write out the generated files.  This can only be
+used with static schema generation.
+
 =head2 generate_pod
 
 By default POD will be generated for columns and relationships, using database
@@ -520,6 +532,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.
 
@@ -537,21 +550,77 @@ 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
+
+The function is also passed a coderef that can be called with either
+of the hashref forms to get the moniker mapped accordingly.  This is
+useful if you need to handle some monikers specially, but want to use
+the hashref form for the rest.
+
+=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
@@ -566,6 +635,26 @@ 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>, plus a coderef similar to the one
+described in L</moniker_map>.
+
+L</moniker_map> takes precedence over this.
+
 =head2 col_accessor_map
 
 Same as moniker_map, but for column accessor names.  If a coderef is
@@ -581,6 +670,7 @@ passed, the code is called with arguments of
       schema_class    => name of the schema class we are building,
       column_info     => hashref of column info (data_type, is_nullable, etc),
    }
+   coderef ref that can be called with a hashref map
 
 the L<table object|DBIx::Class::Schema::Loader::Table> stringifies to the
 unqualified table name.
@@ -607,7 +697,7 @@ instance, you could have
 and relationships that would have been named C<bar> will now be named C<baz>
 except that in the table whose moniker is C<Foo> it will be named C<blat>.
 
-If it is a coderef, the argument passed will be a hashref of this form:
+If it is a coderef, it will be passed a hashref of this form:
 
     {
         name           => default relationship name,
@@ -624,6 +714,8 @@ If it is a coderef, the argument passed will be a hashref of this form:
         link_rel_name  => name of the relationship to the link table
     }
 
+In addition it is passed a coderef that can be called with a hashref map.
+
 DBICSL will try to use the value returned as the relationship name.
 
 =head2 inflect_plural
@@ -771,6 +863,14 @@ made to Loader-generated code.
 Again, you should be using version control on your schema classes.  Be
 careful with this option.
 
+=head2 omit_version
+
+Omit the package version from the signature comment.
+
+=head2 omit_timestamp
+
+Omit the creation timestamp from the signature comment.
+
 =head2 custom_column_info
 
 Hook for adding extra attributes to the
@@ -894,6 +994,13 @@ Automatically promotes the largest unique constraints with non-nullable columns
 on tables to primary keys, assuming there is only one largest unique
 constraint.
 
+=head2 allow_extra_m2m_cols
+
+Generate C<many_to_many> relationship bridges even if the link table has
+extra columns other than the foreign keys.  The primary key must still
+equal the union of the foreign keys.
+
+
 =head2 filter_generated_code
 
 An optional hook that lets you filter the generated text for various classes
@@ -910,8 +1017,19 @@ be generated.
 
     filter_generated_code => sub {
         my ($type, $class, $text) = @_;
-       ...
-       return $new_code;
+        ...
+        return $new_code;
+    }
+
+You can also use this option to set L<perltidy markers|perltidy/Skipping
+Selected Sections of Code> in your generated classes.  This will leave
+the generated code in the default format, but will allow you to tidy
+your classes at any point in future, without worrying about changing the
+portions of the file which are checksummed, since C<perltidy> will just
+ignore all text between the markers.
+
+    filter_generated_code => sub {
+        return "#<<<\n$_[2]\n#>>>";
     }
 
 =head1 METHODS
@@ -922,7 +1040,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;
@@ -1041,6 +1159,7 @@ sub new {
     $self->{class_to_table} = {};
     $self->{classes}  = {};
     $self->{_upgrading_classes} = {};
+    $self->{generated_classes} = [];
 
     $self->{schema_class} ||= ( ref $self->{schema} || $self->{schema} );
     $self->{schema} ||= $self->{schema_class};
@@ -1052,6 +1171,10 @@ sub new {
             if $self->{dump_overwrite};
 
     $self->{dynamic} = ! $self->{dump_directory};
+
+    croak "dry_run can only be used with static schema generation"
+        if $self->dynamic and $self->dry_run;
+
     $self->{temp_directory} ||= File::Temp::tempdir( 'dbicXXXX',
                                                      TMPDIR  => 1,
                                                      CLEANUP => 1,
@@ -1168,11 +1291,18 @@ sub new {
         if (ref $self->moniker_parts ne 'ARRAY') {
             croak 'moniker_parts must be an arrayref';
         }
-        if ((firstidx { $_ eq 'name' } @{ $self->moniker_parts }) == -1) {
+        if (none { $_ eq 'name' } @{ $self->moniker_parts }) {
             croak "moniker_parts option *must* contain 'name'";
         }
     }
 
+    if (not defined $self->moniker_part_separator) {
+        $self->moniker_part_separator('');
+    }
+    if (not defined $self->moniker_part_map) {
+        $self->moniker_part_map({}),
+    }
+
     return $self;
 }
 
@@ -1341,7 +1471,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;
         }
@@ -1364,8 +1494,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)) }) || '');
     }
@@ -1656,6 +1788,8 @@ sub _load_tables {
         # The relationship loader needs a working schema
         local $self->{quiet} = 1;
         local $self->{dump_directory} = $self->{temp_directory};
+        local $self->{generated_classes} = [];
+        local $self->{dry_run} = 0;
         $self->_reload_classes(\@tables);
         $self->_load_relationships(\@tables);
 
@@ -1691,6 +1825,8 @@ sub _reload_classes {
 
     unshift @INC, $self->dump_directory;
 
+    return if $self->dry_run;
+
     my @to_register;
     my %have_source = map { $_ => $self->schema->source($_) }
         $self->schema->sources;
@@ -1786,6 +1922,8 @@ sub get_dump_filename {
 sub _ensure_dump_subdirs {
     my ($self, $class) = (@_);
 
+    return if $self->dry_run;
+
     my @name_parts = split(/::/, $class);
     pop @name_parts; # we don't care about the very last element,
                      # which is a filename
@@ -1922,8 +2060,8 @@ sub _dump_to_dir {
 sub _sig_comment {
     my ($self, $version, $ts) = @_;
     return qq|\n\n# Created by DBIx::Class::Schema::Loader|
-         . qq| v| . $version
-         . q| @ | . $ts
+         . (defined($version) ? q| v| . $version : '')
+         . (defined($ts) ? q| @ | . $ts : '')
          . qq|\n# DO NOT MODIFY THIS OR ANYTHING ABOVE! md5sum:|;
 }
 
@@ -1933,7 +2071,7 @@ sub _write_classfile {
     my $filename = $self->_get_dump_filename($class);
     $self->_ensure_dump_subdirs($class);
 
-    if (-f $filename && $self->really_erase_my_files) {
+    if (-f $filename && $self->really_erase_my_files && !$self->dry_run) {
         warn "Deleting existing file '$filename' due to "
             . "'really_erase_my_files' setting\n" unless $self->quiet;
         unlink($filename);
@@ -1957,7 +2095,7 @@ sub _write_classfile {
         if (-f $old_filename) {
             $custom_content = ($self->_parse_generated_file ($old_filename))[4];
 
-            unlink $old_filename;
+            unlink $old_filename unless $self->dry_run;
         }
     }
 
@@ -2024,10 +2162,10 @@ sub _write_classfile {
                 croak "filter '$filter' exited non-zero: $exit_code";
             }
         }
-       if (not $text or not $text =~ /\bpackage\b/) {
-           warn("$class skipped due to filter") if $self->debug;
-           return;
-       }
+        if (not $text or not $text =~ /\bpackage\b/) {
+            warn("$class skipped due to filter") if $self->debug;
+            return;
+        }
     }
 
     # Check and see if the dump is in fact different
@@ -2040,9 +2178,13 @@ sub _write_classfile {
       }
     }
 
+    push @{$self->generated_classes}, $class;
+
+    return if $self->dry_run;
+
     $text .= $self->_sig_comment(
-      $self->version_to_dump,
-      POSIX::strftime('%Y-%m-%d %H:%M:%S', localtime)
+      $self->omit_version ? undef : $self->version_to_dump,
+      $self->omit_timestamp ? undef : POSIX::strftime('%Y-%m-%d %H:%M:%S', localtime)
     );
 
     open(my $fh, '>:encoding(UTF-8)', $filename)
@@ -2095,13 +2237,16 @@ sub _parse_generated_file {
         qr{^(# DO NOT MODIFY THIS OR ANYTHING ABOVE! md5sum:)([A-Za-z0-9/+]{22})\r?\n};
 
     my ($md5, $ts, $ver, $gen);
+    local $_;
     while(<$fh>) {
         if(/$mark_re/) {
             my $pre_md5 = $1;
             $md5 = $2;
 
             # Pull out the version and timestamp from the line above
-            ($ver, $ts) = $gen =~ m/^# Created by DBIx::Class::Schema::Loader v(.*?) @ (.*?)\r?\Z/m;
+            ($ver, $ts) = $gen =~ m/^# Created by DBIx::Class::Schema::Loader( v[\d.]+)?( @ [\d-]+ [\d:]+)?\r?\Z/m;
+            $ver =~ s/^ v// if $ver;
+            $ts =~ s/^ @ // if $ts;
 
             $gen .= $pre_md5;
             croak "Checksum mismatch in '$fn', the auto-generated part of the file has been modified outside of this loader.  Aborting.\nIf you want to overwrite these modifications, set the 'overwrite_modifications' loader option.\n"
@@ -2343,10 +2488,32 @@ 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 );
+        my $cb = sub {
+            my ($cb_map) = @_;
+            croak "reentered map must be a hashref"
+                unless 'HASH' eq ref($cb_map);
+            return $self->_run_user_map($cb_map, $default_code, $ident, @extra);
+        };
+        $new_ident = $map->( $ident, $default_ident, @extra, $cb );
     }
 
     $new_ident ||= $default_ident;
@@ -2393,6 +2560,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) = @_;
@@ -2403,6 +2575,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);
@@ -2560,7 +2735,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 };
 
@@ -2569,6 +2745,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);
         }
@@ -2596,10 +2782,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 {
@@ -2844,12 +3030,7 @@ sub _base_class_pod {
 
     return '' unless $self->generate_pod;
 
-    return <<"EOF"
-=head1 BASE CLASS: L<$base_class>
-
-=cut
-
-EOF
+    return "\n=head1 BASE CLASS: L<$base_class>\n\n=cut\n\n";
 }
 
 sub _filter_comment {
@@ -2972,6 +3153,11 @@ Returns a hashref of table to class mappings.  In some cases it will
 contain multiple entries per table for the original and normalized table
 names, as above in L</monikers>.
 
+=head2 generated_classes
+
+Returns an arrayref of classes that were actually generated (i.e. not
+skipped because there were no changes).
+
 =head1 NON-ENGLISH DATABASES
 
 If you use the loader on a database with table and column names in a language