X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FDBIx%2FClass%2FSchema%2FLoader%2FBase.pm;h=1a6d5a1006a54dd9a5a182136efa84e9f45fb894;hb=7cbfc0c178d368a5aaf587cade3b167db1ced8ad;hp=419b9eacf20d8f6a38ba618aab37aa0d84bd1cc8;hpb=49643e1dff62e16331c30f51953d548d94da1d30;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 419b9ea..1a6d5a1 100644 --- a/lib/DBIx/Class/Schema/Loader/Base.pm +++ b/lib/DBIx/Class/Schema/Loader/Base.pm @@ -18,13 +18,13 @@ use Class::Unload; use Class::Inspector (); use Scalar::Util 'looks_like_number'; use File::Slurp 'slurp'; -use DBIx::Class::Schema::Loader::Utils qw/split_name dumper_squashed eval_without_redefine_warnings/; +use DBIx::Class::Schema::Loader::Utils qw/split_name dumper_squashed eval_package_without_redefine_warnings class_path/; use DBIx::Class::Schema::Loader::Optional::Dependencies (); use Try::Tiny; use DBIx::Class (); use namespace::clean; -our $VERSION = '0.07002'; +our $VERSION = '0.07010'; __PACKAGE__->mk_group_ro_accessors('simple', qw/ schema @@ -39,7 +39,7 @@ __PACKAGE__->mk_group_ro_accessors('simple', qw/ skip_relationships skip_load_external moniker_map - column_accessor_map + col_accessor_map custom_column_info inflect_singular inflect_plural @@ -51,6 +51,7 @@ __PACKAGE__->mk_group_ro_accessors('simple', qw/ default_resultset_class schema_base_class result_base_class + result_roles use_moose overwrite_modifications @@ -85,8 +86,13 @@ __PACKAGE__->mk_group_accessors('simple', qw/ pod_comment_spillover_length preserve_case col_collision_map + rel_collision_map real_dump_directory + result_components_map + result_roles_map datetime_undef_if_invalid + _result_class_methods + naming_set /); =head1 NAME @@ -307,7 +313,7 @@ together. Examples: stations_visited | StationVisited routeChange | RouteChange -=head2 column_accessor_map +=head2 col_accessor_map Same as moniker_map, but for column accessor names. If a coderef is passed, the code is called with arguments of @@ -363,6 +369,42 @@ List of additional components to be loaded into all of your table classes. A good example would be L +=head2 result_components_map + +A hashref of moniker keys and component values. Unlike C, which +loads the given components into every Result class, this option allows you to +load certain components for specified Result classes. For example: + + result_components_map => { + StationVisited => '+YourApp::Schema::Component::StationVisited', + RouteChange => [ + '+YourApp::Schema::Component::RouteChange', + 'InflateColumn::DateTime', + ], + } + +You may use this in conjunction with C. + +=head2 result_roles + +List of L roles to be applied to all of your Result classes. + +=head2 result_roles_map + +A hashref of moniker keys and role values. Unlike C, which +applies the given roles to every Result class, this option allows you to apply +certain roles for specified Result classes. For example: + + result_roles_map => { + StationVisited => [ + 'YourApp::Role::Building', + 'YourApp::Role::Destination', + ], + RouteChange => 'YourApp::Role::TripEvent', + } + +You may use this in conjunction with C. + =head2 use_namespaces This is now the default, to go back to L pass @@ -516,6 +558,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 @@ -528,7 +578,7 @@ my $CURRENT_V = 'v7'; my @CLASS_ARGS = qw( schema_base_class result_base_class additional_base_classes - left_base_classes additional_classes components + left_base_classes additional_classes components result_roles ); # ensure that a peice of object data is a valid arrayref, creating @@ -553,6 +603,10 @@ by L. sub new { my ( $class, %args ) = @_; + if (exists $args{column_accessor_map}) { + $args{col_accessor_map} = delete $args{column_accessor_map}; + } + my $self = { %args }; # don't lose undef options @@ -574,14 +628,56 @@ sub new { } } + $self->result_components_map($self->{result_component_map}) + if defined $self->{result_component_map}; + + $self->result_roles_map($self->{result_role_map}) + if defined $self->{result_role_map}; + + croak "the result_roles and result_roles_map options may only be used in conjunction with use_moose=1" + if ((not defined $self->use_moose) || (not $self->use_moose)) + && ((defined $self->result_roles) || (defined $self->result_roles_map)); + $self->_ensure_arrayref(qw/additional_classes additional_base_classes left_base_classes components + result_roles /); $self->_validate_class_args; + croak "result_components_map must be a hash" + if defined $self->result_components_map + && ref $self->result_components_map ne 'HASH'; + + if ($self->result_components_map) { + my %rc_map = %{ $self->result_components_map }; + foreach my $moniker (keys %rc_map) { + $rc_map{$moniker} = [ $rc_map{$moniker} ] unless ref $rc_map{$moniker}; + } + $self->result_components_map(\%rc_map); + } + else { + $self->result_components_map({}); + } + $self->_validate_result_components_map; + + croak "result_roles_map must be a hash" + if defined $self->result_roles_map + && ref $self->result_roles_map ne 'HASH'; + + if ($self->result_roles_map) { + my %rr_map = %{ $self->result_roles_map }; + foreach my $moniker (keys %rr_map) { + $rr_map{$moniker} = [ $rr_map{$moniker} ] unless ref $rr_map{$moniker}; + } + $self->result_roles_map(\%rr_map); + } else { + $self->result_roles_map({}); + } + $self->_validate_result_roles_map; + if ($self->use_moose) { if (not DBIx::Class::Schema::Loader::Optional::Dependencies->req_ok_for('use_moose')) { die sprintf "You must install the following CPAN modules to enable the use_moose option: %s.\n", @@ -613,6 +709,13 @@ sub new { $self->version_to_dump($DBIx::Class::Schema::Loader::VERSION); $self->schema_version_to_dump($DBIx::Class::Schema::Loader::VERSION); + if (not defined $self->naming) { + $self->naming_set(0); + } + else { + $self->naming_set(1); + } + if ((not ref $self->naming) && defined $self->naming) { my $naming_ver = $self->naming; $self->{naming} = { @@ -670,8 +773,6 @@ Dynamic schema detected, will run in 0.04006 mode. Set the 'naming' attribute or the SCHEMA_LOADER_BACKCOMPAT environment variable to disable this warning. -Also consider setting 'use_namespaces => 1' if/when upgrading. - See perldoc DBIx::Class::Schema::Loader::Manual::UpgradingFromV4 for more details. EOF @@ -680,6 +781,10 @@ EOF $self->_upgrading_from('v4'); } + if ((not defined $self->use_namespaces) && (not $self->naming_set)) { + $self->use_namespaces(1); + } + $self->naming->{relationships} ||= 'v4'; $self->naming->{monikers} ||= 'v4'; @@ -775,32 +880,59 @@ EOF sub _validate_class_args { my $self = shift; - my $args = shift; foreach my $k (@CLASS_ARGS) { next unless $self->$k; my @classes = ref $self->$k eq 'ARRAY' ? @{ $self->$k } : $self->$k; - foreach my $c (@classes) { - # components default to being under the DBIx::Class namespace unless they - # are preceeded with a '+' - if ( $k =~ m/components$/ && $c !~ s/^\+// ) { - $c = 'DBIx::Class::' . $c; - } + $self->_validate_classes($k, \@classes); + } +} - # 1 == installed, 0 == not installed, undef == invalid classname - my $installed = Class::Inspector->installed($c); - if ( defined($installed) ) { - if ( $installed == 0 ) { - croak qq/$c, as specified in the loader option "$k", is not installed/; - } - } else { - croak qq/$c, as specified in the loader option "$k", is an invalid class name/; +sub _validate_result_components_map { + my $self = shift; + + foreach my $classes (values %{ $self->result_components_map }) { + $self->_validate_classes('result_components_map', $classes); + } +} + +sub _validate_result_roles_map { + my $self = shift; + + foreach my $classes (values %{ $self->result_roles_map }) { + $self->_validate_classes('result_roles_map', $classes); + } +} + +sub _validate_classes { + my $self = shift; + my $key = shift; + my $classes = shift; + + # make a copy to not destroy original + my @classes = @$classes; + + foreach my $c (@classes) { + # components default to being under the DBIx::Class namespace unless they + # are preceeded with a '+' + if ( $key =~ m/component/ && $c !~ s/^\+// ) { + $c = 'DBIx::Class::' . $c; + } + + # 1 == installed, 0 == not installed, undef == invalid classname + my $installed = Class::Inspector->installed($c); + if ( defined($installed) ) { + if ( $installed == 0 ) { + croak qq/$c, as specified in the loader option "$key", is not installed/; } + } else { + croak qq/$c, as specified in the loader option "$key", is an invalid class name/; } } } + sub _find_file_in_inc { my ($self, $file) = @_; @@ -815,20 +947,10 @@ sub _find_file_in_inc { return; } -sub _class_path { - my ($self, $class) = @_; - - my $class_path = $class; - $class_path =~ s{::}{/}g; - $class_path .= '.pm'; - - return $class_path; -} - sub _find_class_in_inc { my ($self, $class) = @_; - return $self->_find_file_in_inc($self->_class_path($class)); + return $self->_find_file_in_inc(class_path($class)); } sub _rewriting { @@ -882,7 +1004,7 @@ sub _load_external { my $code = $self->_rewrite_old_classnames(scalar slurp $real_inc_path); if ($self->dynamic) { # load the class too - eval_without_redefine_warnings($code); + eval_package_without_redefine_warnings($class, $code); } $self->_ext_stmt($class, @@ -923,7 +1045,7 @@ been used by an older version of the Loader. * PLEASE RENAME THIS CLASS: from '$old_class' to '$class', as that is the new name of the Result. EOF - eval_without_redefine_warnings($code); + eval_package_without_redefine_warnings($class, $code); } chomp $code; @@ -1008,7 +1130,7 @@ sub _relbuilder { ->{ $self->naming->{relationships}}; my $relbuilder_class = 'DBIx::Class::Schema::Loader::RelBuilder'.$relbuilder_suff; - eval "require $relbuilder_class"; die $@ if $@; + $self->ensure_class_loaded($relbuilder_class); $relbuilder_class->new( $self ); }; @@ -1150,12 +1272,10 @@ sub _moose_metaclass { sub _reload_class { my ($self, $class) = @_; - my $class_path = $self->_class_path($class); - delete $INC{ $class_path }; + delete $INC{ +class_path($class) }; -# kill redefined warnings try { - eval_without_redefine_warnings ("require $class"); + eval_package_without_redefine_warnings ($class, "require $class"); } catch { my $source = slurp $self->_get_dump_filename($class); @@ -1485,6 +1605,18 @@ sub _inject { $self->_raw_stmt($target, "use base qw/$blist/;"); } +sub _with { + my $self = shift; + my $target = shift; + + my $rlist = join(q{, }, map { qq{'$_'} } @_); + + return unless $rlist; + + warn "$target: with $rlist;" if $self->debug; + $self->_raw_stmt($target, "\nwith $rlist;"); +} + sub _result_namespace { my ($self, $schema_class, $ns) = @_; my @result_namespace; @@ -1548,55 +1680,83 @@ sub _make_src_class { unless $table_class eq $old_class; } -# this was a bad idea, should be ok now without it -# my $table_normalized = lc $table; -# $self->classes->{$table_normalized} = $table_class; -# $self->monikers->{$table_normalized} = $table_moniker; - - $self->classes->{$table} = $table_class; + $self->classes->{$table} = $table_class; $self->monikers->{$table} = $table_moniker; $self->_use ($table_class, @{$self->additional_classes}); $self->_inject($table_class, @{$self->left_base_classes}); - if (my @components = @{ $self->components }) { - $self->_dbic_stmt($table_class, 'load_components', @components); - } + my @components = @{ $self->components || [] }; + + push @components, @{ $self->result_components_map->{$table_moniker} } + if exists $self->result_components_map->{$table_moniker}; + + $self->_dbic_stmt($table_class, 'load_components', @components) if @components; $self->_inject($table_class, @{$self->additional_base_classes}); + + my @roles = @{ $self->result_roles || [] }; + push @roles, @{ $self->result_roles_map->{$table_moniker} } + if exists $self->result_roles_map->{$table_moniker}; + + $self->_with($table_class, @roles) if @roles; } -sub _resolve_col_accessor_collisions { - my ($self, $table, $col_info) = @_; +sub _is_result_class_method { + my ($self, $name, $table_name) = @_; - my $base = $self->result_base_class || 'DBIx::Class::Core'; - my @components = map "DBIx::Class::$_", @{ $self->components || [] }; + my $table_moniker = $table_name ? $self->_table2moniker($table_name) : ''; - my $table_name = ref $table ? $$table : $table; + $self->_result_class_methods({}) + if not defined $self->_result_class_methods; + + if (not exists $self->_result_class_methods->{$table_moniker}) { + my (@methods, %methods); + my $base = $self->result_base_class || 'DBIx::Class::Core'; + + my @components = @{ $self->components || [] }; - my @methods; + push @components, @{ $self->result_components_map->{$table_moniker} } + if exists $self->result_components_map->{$table_moniker}; - for my $class ($base, @components, $self->use_moose ? 'Moose::Object' : ()) { - eval "require ${class};"; - die $@ if $@; + for my $c (@components) { + $c = $c =~ /^\+/ ? substr($c,1) : "DBIx::Class::$c"; + } + + my @roles = @{ $self->result_roles || [] }; + + push @roles, @{ $self->result_roles_map->{$table_moniker} } + if exists $self->result_roles_map->{$table_moniker}; + + for my $class ($base, @components, + ($self->use_moose ? 'Moose::Object' : ()), @roles) { + $self->ensure_class_loaded($class); + + push @methods, @{ Class::Inspector->methods($class) || [] }; + } - push @methods, @{ Class::Inspector->methods($class) || [] }; + push @methods, @{ Class::Inspector->methods('UNIVERSAL') }; + + @methods{@methods} = (); + + $self->_result_class_methods->{$table_moniker} = \%methods; } + my $result_methods = $self->_result_class_methods->{$table_moniker}; - 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, $table_name)) { my $mapped = 0; if (my $map = $self->col_collision_map) { @@ -1610,7 +1770,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; @@ -1619,7 +1779,7 @@ EOF } } -# use the same logic to run moniker_map, column_accessor_map, and +# use the same logic to run moniker_map, col_accessor_map, and # relationship_name_map sub _run_user_map { my ( $self, $map, $default_code, $ident, @extra ) = @_; @@ -1657,7 +1817,7 @@ sub _make_column_accessor_name { my ($self, $column_name, $column_context_info ) = @_; my $accessor = $self->_run_user_map( - $self->column_accessor_map, + $self->col_accessor_map, sub { $self->_default_column_accessor_name( shift ) }, $column_name, $column_context_info, @@ -2085,6 +2245,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