X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FDBIx%2FClass%2FSchema%2FLoader%2FBase.pm;h=c35226c57dcd3a8363d20779db1dd0fb60294f6c;hb=a7116285a72cb974e5e1848b8f202981b0106d98;hp=0f3aa0cb227e2eccae2e96757be70a4c49ee8bb0;hpb=1ad8e8c3ce53cba4f8a34e37567ed1187b9e54b8;p=dbsrgits%2FDBIx-Class-Schema-Loader.git diff --git a/lib/DBIx/Class/Schema/Loader/Base.pm b/lib/DBIx/Class/Schema/Loader/Base.pm index 0f3aa0c..c35226c 100644 --- a/lib/DBIx/Class/Schema/Loader/Base.pm +++ b/lib/DBIx/Class/Schema/Loader/Base.pm @@ -22,6 +22,7 @@ use DBIx::Class::Schema::Loader::Utils qw/split_name dumper_squashed eval_withou use DBIx::Class::Schema::Loader::Optional::Dependencies (); use Try::Tiny; use DBIx::Class (); +use Class::Load 'load_class'; use namespace::clean; our $VERSION = '0.07002'; @@ -39,6 +40,7 @@ __PACKAGE__->mk_group_ro_accessors('simple', qw/ skip_relationships skip_load_external moniker_map + column_accessor_map custom_column_info inflect_singular inflect_plural @@ -84,7 +86,9 @@ __PACKAGE__->mk_group_accessors('simple', qw/ pod_comment_spillover_length preserve_case col_collision_map + rel_collision_map real_dump_directory + datetime_undef_if_invalid /); =head1 NAME @@ -305,6 +309,22 @@ together. Examples: stations_visited | StationVisited routeChange | RouteChange +=head2 column_accessor_map + +Same as moniker_map, but for column accessor names. If a coderef is +passed, the code is called with arguments of + + the name of the column in the underlying database, + default accessor name that DBICSL would ordinarily give this column, + { + 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, + 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), + } + =head2 inflect_plural Just like L above (can be hash/code-ref, falls back to default @@ -442,6 +462,15 @@ columns with the DATE/DATETIME/TIMESTAMP data_types. Sets the locale attribute for L for all columns with the DATE/DATETIME/TIMESTAMP data_types. +=head2 datetime_undef_if_invalid + +Pass a C<0> for this option when using MySQL if you B want C<< +datetime_undef_if_invalid => 1 >> in your column info for DATE, DATETIME and +TIMESTAMP columns. + +The default is recommended to deal with data such as C<00/00/00> which +sometimes ends up in such columns in MySQL. + =head2 config_file File in Perl format, which should return a HASH reference, from which to read @@ -489,6 +518,14 @@ Examples: col_collision_map => { '(foo).*(bar)' => 'column_%s_%s' } +=head2 rel_collision_map + +Works just like L, but for relationship names/accessors +rather than column names/accessors. + +The default is to just append C<_rel> to the relationship name, see +L. + =head1 METHODS None of these methods are intended for direct invocation by regular @@ -981,7 +1018,7 @@ sub _relbuilder { ->{ $self->naming->{relationships}}; my $relbuilder_class = 'DBIx::Class::Schema::Loader::RelBuilder'.$relbuilder_suff; - eval "require $relbuilder_class"; die $@ if $@; + load_class $relbuilder_class; $relbuilder_class->new( $self ); }; @@ -1131,7 +1168,8 @@ sub _reload_class { eval_without_redefine_warnings ("require $class"); } catch { - die "Failed to reload class $class: $_"; + my $source = slurp $self->_get_dump_filename($class); + die "Failed to reload class $class: $_.\n\nCLASS SOURCE:\n\n$source"; }; } @@ -1192,7 +1230,7 @@ sub _dump_to_dir { . qq|# DO NOT MODIFY THE FIRST PART OF THIS FILE\n\n|; if ($self->use_moose) { - $schema_text.= qq|use Moose;\nuse MooseX::NonMoose;\nuse namespace::autoclean;\nextends '$schema_base_class';\n\n|; + $schema_text.= qq|use Moose;\nuse namespace::autoclean;\nextends '$schema_base_class';\n\n|; } else { $schema_text .= qq|use strict;\nuse warnings;\n\nuse base '$schema_base_class';\n\n|; @@ -1315,7 +1353,7 @@ sub _write_classfile { } } - $custom_content ||= $self->_default_custom_content; + $custom_content ||= $self->_default_custom_content($is_schema); # If upgrading to use_moose=1 replace default custom content with default Moose custom content. # If there is already custom content, which does not have the Moose content, add it. @@ -1327,10 +1365,10 @@ sub _write_classfile { }; if ($custom_content eq $non_moose_custom_content) { - $custom_content = $self->_default_custom_content; + $custom_content = $self->_default_custom_content($is_schema); } - elsif ($custom_content !~ /\Q@{[$self->_default_moose_custom_content]}\E/) { - $custom_content .= $self->_default_custom_content; + elsif ($custom_content !~ /\Q@{[$self->_default_moose_custom_content($is_schema)]}\E/) { + $custom_content .= $self->_default_custom_content($is_schema); } } elsif (defined $self->use_moose && $old_gen) { @@ -1376,15 +1414,21 @@ sub _write_classfile { } sub _default_moose_custom_content { - return qq|\n__PACKAGE__->meta->make_immutable;|; + my ($self, $is_schema) = @_; + + if (not $is_schema) { + return qq|\n__PACKAGE__->meta->make_immutable;|; + } + + return qq|\n__PACKAGE__->meta->make_immutable(inline_constructor => 0);|; } sub _default_custom_content { - my $self = shift; + my ($self, $is_schema) = @_; my $default = qq|\n\n# You can replace this text with custom| . qq| code or comments, and it will be preserved on regeneration|; if ($self->use_moose) { - $default .= $self->_default_moose_custom_content; + $default .= $self->_default_moose_custom_content($is_schema); } $default .= qq|\n1;\n|; return $default; @@ -1532,36 +1576,46 @@ sub _make_src_class { $self->_inject($table_class, @{$self->additional_base_classes}); } -sub _resolve_col_accessor_collisions { - my ($self, $table, $col_info) = @_; +{ + my %result_methods; - my $base = $self->result_base_class || 'DBIx::Class::Core'; - my @components = map "DBIx::Class::$_", @{ $self->components || [] }; + sub _is_result_class_method { + my ($self, $name) = @_; - my $table_name = ref $table ? $$table : $table; + %result_methods || do { + my @methods; + my $base = $self->result_base_class || 'DBIx::Class::Core'; + my @components = map { /^\+/ ? substr($_,1) : "DBIx::Class::$_" } @{ $self->components || [] }; - my @methods; + for my $class ($base, @components, $self->use_moose ? 'Moose::Object' : ()) { + load_class $class; - for my $class ($base, @components, $self->use_moose ? 'Moose::Object' : ()) { - eval "require ${class};"; - die $@ if $@; + push @methods, @{ Class::Inspector->methods($class) || [] }; + } + + push @methods, @{ Class::Inspector->methods('UNIVERSAL') }; + + @result_methods{@methods} = (); + + # futureproof meta + $result_methods{meta} = undef; + }; - push @methods, @{ Class::Inspector->methods($class) || [] }; - push @methods, @{ Class::Inspector->methods('UNIVERSAL') || [] }; + return exists $result_methods{$name}; } +} - my %methods; - @methods{@methods} = (); +sub _resolve_col_accessor_collisions { + my ($self, $table, $col_info) = @_; - # futureproof meta - $methods{meta} = undef; + my $table_name = ref $table ? $$table : $table; while (my ($col, $info) = each %$col_info) { my $accessor = $info->{accessor} || $col; next if $accessor eq 'id'; # special case (very common column) - if (exists $methods{$accessor}) { + if ($self->_is_result_class_method($accessor)) { my $mapped = 0; if (my $map = $self->col_collision_map) { @@ -1575,7 +1629,7 @@ sub _resolve_col_accessor_collisions { if (not $mapped) { warn <<"EOF"; -Column $col in table $table_name collides with an inherited method. +Column '$col' in table '$table_name' collides with an inherited method. See "COLUMN ACCESSOR COLLISIONS" in perldoc DBIx::Class::Schema::Loader::Base . EOF $info->{accessor} = undef; @@ -1584,10 +1638,51 @@ EOF } } -sub _make_column_accessor_name { - my ($self, $column_name) = @_; +# use the same logic to run moniker_map, column_accessor_map, and +# relationship_name_map +sub _run_user_map { + my ( $self, $map, $default_code, $ident, @extra ) = @_; + + my $default_ident = $default_code->( $ident, @extra ); + my $new_ident; + if( $map && ref $map eq 'HASH' ) { + $new_ident = $map->{ $ident }; + } + elsif( $map && ref $map eq 'CODE' ) { + $new_ident = $map->( $ident, $default_ident, @extra ); + } + + $new_ident ||= $default_ident; + + return $new_ident; +} + +sub _default_column_accessor_name { + my ( $self, $column_name ) = @_; + + my $accessor_name = $column_name; + $accessor_name =~ s/\W+/_/g; + + if ((($self->naming->{column_accessors}||'') =~ /(\d+)/ && $1 < 7) || (not $self->preserve_case)) { + # older naming just lc'd the col accessor and that's all. + return lc $accessor_name; + } return join '_', map lc, split_name $column_name; + +} + +sub _make_column_accessor_name { + my ($self, $column_name, $column_context_info ) = @_; + + my $accessor = $self->_run_user_map( + $self->column_accessor_map, + sub { $self->_default_column_accessor_name( shift ) }, + $column_name, + $column_context_info, + ); + + return $accessor; } # Set up metadata (cols, pks, etc) @@ -1614,34 +1709,33 @@ sub _setup_src_meta { $self->_dbic_stmt($table_class, 'table', $full_table_name); - my $cols = $self->_table_columns($table); + my $cols = $self->_table_columns($table); my $col_info = $self->__columns_info_for($table); + ### generate all the column accessor names while (my ($col, $info) = each %$col_info) { - if ($col =~ /\W/) { - ($info->{accessor} = $col) =~ s/\W+/_/g; - } - } + # hashref of other info that could be used by + # user-defined accessor map functions + my $context = { + table_class => $table_class, + table_moniker => $table_moniker, + table_name => $table_name, + full_table_name => $full_table_name, + schema_class => $schema_class, + column_info => $info, + }; - if ($self->preserve_case) { - while (my ($col, $info) = each %$col_info) { - if ($col ne lc($col)) { - if ((not exists $self->naming->{column_accessors}) || (($self->naming->{column_accessors} =~ /(\d+)/)[0] >= 7)) { - $info->{accessor} = $self->_make_column_accessor_name($info->{accessor} || $col); - } - else { - $info->{accessor} = lc($info->{accessor} || $col); - } - } - } - } - else { - # XXX this needs to go away - $col_info = { map { lc($_), $col_info->{$_} } keys %$col_info }; + $info->{accessor} = $self->_make_column_accessor_name( $col, $context ); } $self->_resolve_col_accessor_collisions($full_table_name, $col_info); + # prune any redundant accessor names + while (my ($col, $info) = each %$col_info) { + no warnings 'uninitialized'; + delete $info->{accessor} if $info->{accessor} eq $col; + } + my $fks = $self->_table_fk_info($table); foreach my $fkdef (@$fks) { @@ -1735,18 +1829,11 @@ sub _default_table2moniker { sub _table2moniker { my ( $self, $table ) = @_; - my $moniker; - - if( ref $self->moniker_map eq 'HASH' ) { - $moniker = $self->moniker_map->{$table}; - } - elsif( ref $self->moniker_map eq 'CODE' ) { - $moniker = $self->moniker_map->($table); - } - - $moniker ||= $self->_default_table2moniker($table); - - return $moniker; + $self->_run_user_map( + $self->moniker_map, + sub { $self->_default_table2moniker( shift ) }, + $table + ); } sub _load_relationships { @@ -2017,6 +2104,20 @@ below the md5: Another option is to use the L option. +=head1 RELATIONSHIP NAME COLLISIONS + +In very rare cases, you may get a collision between a generated relationship +name and a method in your Result class, for example if you have a foreign key +called C. + +This is a problem because relationship names are also relationship accessor +methods in L. + +The default behavior is to append C<_rel> to the relationship name and print +out a warning that refers to this text. + +You can also control the renaming with the L option. + =head1 SEE ALSO L