X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FDBIx%2FClass%2FSchema%2FLoader%2FBase.pm;h=74f99698e90f101218e6efe00300a2135b9e19ab;hb=refs%2Fheads%2Fregex_capture_issues;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..74f9969 100644 --- a/lib/DBIx/Class/Schema/Loader/Base.pm +++ b/lib/DBIx/Class/Schema/Loader/Base.pm @@ -17,14 +17,16 @@ use File::Temp qw//; 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 File::Slurp 'read_file'; +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 Encode qw/encode/; +use List::MoreUtils 'all'; use namespace::clean; -our $VERSION = '0.07002'; +our $VERSION = '0.07010'; __PACKAGE__->mk_group_ro_accessors('simple', qw/ schema @@ -39,6 +41,7 @@ __PACKAGE__->mk_group_ro_accessors('simple', qw/ skip_relationships skip_load_external moniker_map + col_accessor_map custom_column_info inflect_singular inflect_plural @@ -50,6 +53,7 @@ __PACKAGE__->mk_group_ro_accessors('simple', qw/ default_resultset_class schema_base_class result_base_class + result_roles use_moose overwrite_modifications @@ -67,6 +71,9 @@ __PACKAGE__->mk_group_ro_accessors('simple', qw/ config_file loader_class qualify_objects + tables + class_to_table + uniq_to_primary /); @@ -84,7 +91,14 @@ __PACKAGE__->mk_group_accessors('simple', qw/ pod_comment_spillover_length preserve_case col_collision_map + rel_collision_map + rel_name_map real_dump_directory + result_components_map + result_roles_map + datetime_undef_if_invalid + _result_class_methods + naming_set /); =head1 NAME @@ -195,6 +209,23 @@ transition instead of just being lowercased, so C becomes C. If you don't have any CamelCase table or column names, you can upgrade without breaking any of your code. +=item preserve + +For L, this option does not inflect the table names but makes +monikers based on the actual name. For L this option does +not normalize CamelCase column names to lowercase column accessors, but makes +accessors that are the same names as the columns (with any non-\w chars +replaced with underscores.) + +=item singular + +For L, singularizes the names using the most current inflector. This +is the same as setting the option to L. + +=item plural + +For L, pluralizes the names, using the most current inflector. + =back Dynamic schemas will always default to the 0.04XXX relationship names and won't @@ -273,8 +304,12 @@ decides to execute will be C-ed before execution. =head2 db_schema Set the name of the schema to load (schema in the sense that your database -vendor means it). Does not currently support loading more than one schema -name. +vendor means it). + +Can be set to an arrayref of schema names for multiple schemas, or the special +value C<%> for all schemas. + +Multiple schemas have only been tested on PostgreSQL. =head2 constraint @@ -305,6 +340,59 @@ together. Examples: stations_visited | StationVisited routeChange | RouteChange +=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 + + 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 rel_name_map + +Similar in idea to moniker_map, but different in the details. It can be +a hashref or a code ref. + +If it is a hashref, keys can be either the default relationship name, or the +moniker. The keys that are the default relationship name should map to the +name you want to change the relationship to. Keys that are monikers should map +to hashes mapping relationship names to their translation. You can do both at +once, and the more specific moniker version will be picked up first. So, for +instance, you could have + + { + bar => "baz", + Foo => { + bar => "blat", + }, + } + +and relationships that would have been named C will now be named C +except that in the table whose moniker is C it will be named C. + +If it is a coderef, the argument passed will be a hashref of this form: + + { + name => default relationship name, + type => the relationship type eg: C, + local_class => name of the DBIC class we are building, + local_moniker => moniker of the DBIC class we are building, + local_columns => columns in this table in the relationship, + 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, + } + +DBICSL will try to use the value returned as the relationship name. + =head2 inflect_plural Just like L above (can be hash/code-ref, falls back to default @@ -345,6 +433,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 L, 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 L. + +=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 L, 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 L. + =head2 use_namespaces This is now the default, to go back to L pass @@ -442,6 +566,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 +622,20 @@ 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. + +=head2 uniq_to_primary + +Automatically promotes the largest unique constraints with non-nullable columns +on tables to primary keys, assuming there is only one largest unique +constraint. + =head1 METHODS None of these methods are intended for direct invocation by regular @@ -501,7 +648,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 @@ -526,6 +673,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 @@ -547,14 +698,64 @@ sub new { } } + if (defined $self->{result_component_map}) { + if (defined $self->result_components_map) { + croak "Specify only one of result_components_map or result_component_map"; + } + $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"; + } + $self->result_roles_map($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", @@ -563,7 +764,9 @@ sub new { } $self->{monikers} = {}; - $self->{classes} = {}; + $self->{tables} = {}; + $self->{class_to_table} = {}; + $self->{classes} = {}; $self->{_upgrading_classes} = {}; $self->{schema_class} ||= ( ref $self->{schema} || $self->{schema} ); @@ -586,6 +789,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} = { @@ -624,6 +834,45 @@ sub new { } } + if (my $rel_collision_map = $self->rel_collision_map) { + if (my $reftype = ref $rel_collision_map) { + if ($reftype ne 'HASH') { + croak "Invalid type $reftype for option 'rel_collision_map'"; + } + } + else { + $self->rel_collision_map({ '(.*)' => $rel_collision_map }); + } + } + + if (defined(my $rel_name_map = $self->rel_name_map)) { + my $reftype = ref $rel_name_map; + if ($reftype ne 'HASH' && $reftype ne 'CODE') { + croak "Invalid type $reftype for option 'rel_name_map', must be HASH or CODE"; + } + } + + if (defined $self->db_schema) { + if (ref $self->db_schema eq 'ARRAY') { + if (@{ $self->db_schema } > 1) { + $self->{qualify_objects} = 1; + } + elsif (@{ $self->db_schema } == 0) { + $self->{db_schema} = undef; + } + } + elsif (not ref $self->db_schema) { + if ($self->db_schema eq '%') { + $self->{qualify_objects} = 1; + } + + $self->{db_schema} = [ $self->db_schema ]; + } + else { + croak 'db_schema must be an array or single value'; + } + } + $self; } @@ -635,7 +884,7 @@ sub _check_back_compat { # just in case, though no one is likely to dump a dynamic schema $self->schema_version_to_dump('0.04006'); - if (not %{ $self->naming }) { + if (not $self->naming_set) { warn < 1' if/when upgrading. - See perldoc DBIx::Class::Schema::Loader::Manual::UpgradingFromV4 for more details. EOF @@ -653,6 +900,10 @@ EOF $self->_upgrading_from('v4'); } + if ((not defined $self->use_namespaces) && ($self->naming_set)) { + $self->use_namespaces(1); + } + $self->naming->{relationships} ||= 'v4'; $self->naming->{monikers} ||= 'v4'; @@ -667,7 +918,7 @@ EOF } # otherwise check if we need backcompat mode for a static schema - my $filename = $self->_get_dump_filename($self->schema_class); + my $filename = $self->get_dump_filename($self->schema_class); return unless -e $filename; my ($old_gen, $old_md5, $old_ver, $old_ts, $old_custom) = @@ -681,7 +932,14 @@ EOF } my $load_classes = ($old_gen =~ /^__PACKAGE__->load_classes;/m) ? 1 : 0; - my $result_namespace = do { ($old_gen =~ /result_namespace => '([^']+)'/) ? $1 : '' }; + + my $result_namespace = do { ($old_gen =~ /result_namespace => (.+)/) ? $1 : '' }; + my $ds = eval $result_namespace; + die <<"EOF" if $@; +Could not eval expression '$result_namespace' for result_namespace from +$filename: $@ +EOF + $result_namespace = $ds || ''; if ($load_classes && (not defined $self->use_namespaces)) { warn <<"EOF" unless $ENV{SCHEMA_LOADER_BACKCOMPAT}; @@ -748,32 +1006,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) = @_; @@ -788,20 +1073,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 { @@ -852,10 +1127,10 @@ sub _load_external { warn qq/# Loaded external class definition for '$class'\n/ if $self->debug; - my $code = $self->_rewrite_old_classnames(scalar slurp $real_inc_path); + my $code = $self->_rewrite_old_classnames(scalar read_file($real_inc_path, binmode => ':encoding(UTF-8)')); if ($self->dynamic) { # load the class too - eval_without_redefine_warnings($code); + eval_package_without_redefine_warnings($class, $code); } $self->_ext_stmt($class, @@ -875,7 +1150,7 @@ sub _load_external { } if ($old_real_inc_path) { - my $code = slurp $old_real_inc_path; + my $code = read_file($old_real_inc_path, binmode => ':encoding(UTF-8)'); $self->_ext_stmt($class, <<"EOF"); @@ -896,7 +1171,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; @@ -956,8 +1231,7 @@ sub rescan { } } - delete $self->{_dump_storage}; - delete $self->{_relations_started}; + delete @$self{qw/_dump_storage _relations_started _uniqs_started/}; my $loaded = $self->_load_tables(@current); @@ -981,7 +1255,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 ); }; @@ -1030,14 +1304,15 @@ sub _load_tables { $self->{quiet} = 1; local $self->{dump_directory} = $self->{temp_directory}; $self->_reload_classes(\@tables); - $self->_load_relationships($_) for @tables; - $self->_relbuilder->cleanup; + $self->_load_relationships(\@tables); $self->{quiet} = 0; # Remove that temp dir from INC so it doesn't get reloaded @INC = grep $_ ne $self->dump_directory, @INC; } + $self->_load_roles($_) for @tables; + $self->_load_external($_) for map { $self->classes->{$_} } @tables; @@ -1123,15 +1398,14 @@ 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 { - die "Failed to reload class $class: $_"; + my $source = read_file($self->_get_dump_filename($class), binmode => ':encoding(UTF-8)'); + die "Failed to reload class $class: $_.\n\nCLASS SOURCE:\n\n$source"; }; } @@ -1192,7 +1466,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|; @@ -1208,7 +1482,8 @@ sub _dump_to_dir { for my $attr (@attr) { if ($self->$attr) { - $namespace_options .= qq| $attr => '| . $self->$attr . qq|',\n| + my $code = dumper_squashed $self->$attr; + $namespace_options .= qq| $attr => $code,\n| } } $schema_text .= qq|(\n$namespace_options)| if $namespace_options; @@ -1229,22 +1504,30 @@ sub _dump_to_dir { my $src_text = qq|package $src_class;\n\n| . qq|# Created by DBIx::Class::Schema::Loader\n| - . qq|# DO NOT MODIFY THE FIRST PART OF THIS FILE\n\n| - . qq|use strict;\nuse warnings;\n\n|; + . qq|# DO NOT MODIFY THE FIRST PART OF THIS FILE\n\n|; + + $src_text .= $self->_make_pod_heading($src_class); + + $src_text .= qq|use strict;\nuse warnings;\n\n|; + + $src_text .= $self->_base_class_pod($result_base_class) + unless $result_base_class eq 'DBIx::Class::Core'; + if ($self->use_moose) { $src_text.= qq|use Moose;\nuse MooseX::NonMoose;\nuse namespace::autoclean;|; # these options 'use base' which is compile time if (@{ $self->left_base_classes } || @{ $self->additional_base_classes }) { - $src_text .= qq|\nBEGIN { extends '$result_base_class' }\n\n|; + $src_text .= qq|\nBEGIN { extends '$result_base_class' }\n|; } else { - $src_text .= qq|\nextends '$result_base_class';\n\n|; + $src_text .= qq|\nextends '$result_base_class';\n|; } } else { - $src_text .= qq|use base '$result_base_class';\n\n|; + $src_text .= qq|use base '$result_base_class';\n|; } + $self->_write_classfile($src_class, $src_text); } @@ -1315,7 +1598,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 +1610,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) { @@ -1348,7 +1631,7 @@ sub _write_classfile { my $compare_to; if ($old_md5) { $compare_to = $text . $self->_sig_comment($old_ver, $old_ts); - if (Digest::MD5::md5_base64($compare_to) eq $old_md5) { + if (Digest::MD5::md5_base64(encode 'UTF-8', $compare_to) eq $old_md5) { return unless $self->_upgrading_from && $is_schema; } } @@ -1358,11 +1641,11 @@ sub _write_classfile { POSIX::strftime('%Y-%m-%d %H:%M:%S', localtime) ); - open(my $fh, '>', $filename) + open(my $fh, '>:encoding(UTF-8)', $filename) or croak "Cannot open '$filename' for writing: $!"; # Write the top half and its MD5 sum - print $fh $text . Digest::MD5::md5_base64($text) . "\n"; + print $fh $text . Digest::MD5::md5_base64(encode 'UTF-8', $text) . "\n"; # Write out anything loaded via external partial class file in @INC print $fh qq|$_\n| @@ -1376,15 +1659,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; @@ -1395,7 +1684,7 @@ sub _parse_generated_file { return unless -f $fn; - open(my $fh, '<', $fn) + open(my $fh, '<:encoding(UTF-8)', $fn) or croak "Cannot open '$fn' for reading: $!"; my $mark_re = @@ -1412,7 +1701,7 @@ sub _parse_generated_file { $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" - if !$self->overwrite_modifications && Digest::MD5::md5_base64($gen) ne $md5; + if !$self->overwrite_modifications && Digest::MD5::md5_base64(encode 'UTF-8', $gen) ne $md5; last; } @@ -1451,10 +1740,24 @@ 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; + $ns = $ns->[0] if ref $ns; + if ($ns =~ /^\+(.*)/) { # Fully qualified namespace @result_namespace = ($1) @@ -1514,54 +1817,93 @@ 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->tables->{$table_moniker} = $table; + $self->class_to_table->{$table_class} = $table; + + $self->_pod_class_list($table_class, 'ADDITIONAL CLASSES USED', @{$self->additional_classes}); $self->_use ($table_class, @{$self->additional_classes}); + + $self->_pod_class_list($table_class, 'LEFT BASE CLASSES', @{$self->left_base_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}; + + my @fq_components = @components; + foreach my $component (@fq_components) { + if ($component !~ s/^\+//) { + $component = "DBIx::Class::$component"; + } } + $self->_pod_class_list($table_class, 'COMPONENTS LOADED', @fq_components); + + $self->_dbic_stmt($table_class, 'load_components', @components) if @components; + + $self->_pod_class_list($table_class, 'ADDITIONAL BASE CLASSES', @{$self->additional_base_classes}); + $self->_inject($table_class, @{$self->additional_base_classes}); } -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->monikers->{$table_name} : ''; - my $table_name = ref $table ? $$table : $table; + $self->_result_class_methods({}) + if not defined $self->_result_class_methods; - my @methods; + if (not exists $self->_result_class_methods->{$table_moniker}) { + my (@methods, %methods); + my $base = $self->result_base_class || 'DBIx::Class::Core'; - for my $class ($base, @components, $self->use_moose ? 'Moose::Object' : ()) { - eval "require ${class};"; - die $@ if $@; + my @components = @{ $self->components || [] }; - push @methods, @{ Class::Inspector->methods($class) || [] }; - push @methods, @{ Class::Inspector->methods('UNIVERSAL') || [] }; + push @components, @{ $self->result_components_map->{$table_moniker} } + if exists $self->result_components_map->{$table_moniker}; + + 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('UNIVERSAL') }; + + @methods{@methods} = (); + + $self->_result_class_methods->{$table_moniker} = \%methods; } + my $result_methods = $self->_result_class_methods->{$table_moniker}; - my %methods; - @methods{@methods} = (); + return exists $result_methods->{$name}; +} - # futureproof meta - $methods{meta} = undef; +sub _resolve_col_accessor_collisions { + my ($self, $table, $col_info) = @_; 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)) { my $mapped = 0; if (my $map = $self->col_collision_map) { @@ -1575,7 +1917,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' collides with an inherited method. See "COLUMN ACCESSOR COLLISIONS" in perldoc DBIx::Class::Schema::Loader::Base . EOF $info->{accessor} = undef; @@ -1584,12 +1926,66 @@ EOF } } -sub _make_column_accessor_name { - my ($self, $column_name) = @_; +# use the same logic to run moniker_map, col_accessor_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; + } + elsif (($self->naming->{column_accessors}||'') eq 'preserve') { + return $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->col_accessor_map, + sub { $self->_default_column_accessor_name( shift ) }, + $column_name, + $column_context_info, + ); + + return $accessor; +} + +sub _quote { + my ($self, $identifier) = @_; + + my $qt = $self->schema->storage->sql_maker->quote_char || ''; + + if (ref $qt) { + return $qt->[0] . $identifier . $qt->[1]; + } + + return "${qt}${identifier}${qt}"; +} + # Set up metadata (cols, pks, etc) sub _setup_src_meta { my ($self, $table) = @_; @@ -1597,50 +1993,53 @@ sub _setup_src_meta { my $schema = $self->schema; my $schema_class = $self->schema_class; - my $table_class = $self->classes->{$table}; + my $table_class = $self->classes->{$table}; my $table_moniker = $self->monikers->{$table}; my $table_name = $table; - my $name_sep = $self->schema->storage->sql_maker->name_sep; + + my $sql_maker = $self->schema->storage->sql_maker; + my $name_sep = $sql_maker->name_sep; if ($name_sep && $table_name =~ /\Q$name_sep\E/) { - $table_name = \ $self->_quote_table_name($table_name); + $table_name = \ $self->_quote($table_name); } - my $full_table_name = ($self->qualify_objects ? ($self->db_schema . '.') : '') . (ref $table_name ? $$table_name : $table_name); + my $full_table_name = ($self->qualify_objects ? + ($self->_quote($table->schema) . '.') : '') + . (ref $table_name eq 'SCALAR' ? $$table_name : $table_name); # be careful to not create refs Data::Dump can "optimize" - $full_table_name = \do {"".$full_table_name} if ref $table_name; + $full_table_name = \do {"".$full_table_name} if ref $table_name eq 'SCALAR'; $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); + $self->_resolve_col_accessor_collisions($table, $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); @@ -1652,6 +2051,39 @@ sub _setup_src_meta { my $pks = $self->_table_pk_info($table) || []; + my %uniq_tag; # used to eliminate duplicate uniqs + + $uniq_tag{ join("\0", @$pks) }++ if @$pks; # pk is a uniq + + my $uniqs = $self->_table_uniq_info($table) || []; + my @uniqs; + + foreach my $uniq (@$uniqs) { + my ($name, $cols) = @$uniq; + next if $uniq_tag{ join("\0", @$cols) }++; # skip duplicates + push @uniqs, [$name, $cols]; + } + + my @non_nullable_uniqs = grep { + all { $col_info->{$_}{is_nullable} == 0 } @{ $_->[1] } + } @uniqs; + + if ($self->uniq_to_primary && (not @$pks) && @non_nullable_uniqs) { + my @by_colnum = sort { $b->[0] <=> $a->[0] } + map [ scalar @{ $_->[1] }, $_ ], @non_nullable_uniqs; + + if (not (@by_colnum > 1 && $by_colnum[0][0] == $by_colnum[1][0])) { + my @keys = map $_->[1], @by_colnum; + + my $pk = $keys[0]; + + # remove the uniq from list + @uniqs = grep { $_->[0] ne $pk->[0] } @uniqs; + + $pks = $pk->[1]; + } + } + foreach my $pkcol (@$pks) { $col_info->{$pkcol}{is_nullable} = 0; } @@ -1662,19 +2094,13 @@ sub _setup_src_meta { map { $_, ($col_info->{$_}||{}) } @$cols ); - my %uniq_tag; # used to eliminate duplicate uniqs + $self->_dbic_stmt($table_class, 'set_primary_key', @$pks) + if @$pks; - @$pks ? $self->_dbic_stmt($table_class,'set_primary_key',@$pks) - : carp("$table has no primary key"); - $uniq_tag{ join("\0", @$pks) }++ if @$pks; # pk is a uniq - - my $uniqs = $self->_table_uniq_info($table) || []; - for (@$uniqs) { - my ($name, $cols) = @$_; - next if $uniq_tag{ join("\0", @$cols) }++; # skip duplicates + foreach my $uniq (@uniqs) { + my ($name, $cols) = @$uniq; $self->_dbic_stmt($table_class,'add_unique_constraint', $name, $cols); } - } sub __columns_info_for { @@ -1727,7 +2153,13 @@ sub _default_table2moniker { my @words = map lc, split_name $table; my $as_phrase = join ' ', @words; - my $inflected = Lingua::EN::Inflect::Phrase::to_S($as_phrase); + my $inflected = $self->naming->{monikers} eq 'plural' ? + Lingua::EN::Inflect::Phrase::to_PL($as_phrase) + : + $self->naming->{monikers} eq 'preserve' ? + $as_phrase + : + Lingua::EN::Inflect::Phrase::to_S($as_phrase); return join '', map ucfirst, split /\W+/, $inflected; } @@ -1735,32 +2167,32 @@ sub _default_table2moniker { sub _table2moniker { my ( $self, $table ) = @_; - my $moniker; + $self->_run_user_map( + $self->moniker_map, + sub { $self->_default_table2moniker( shift ) }, + $table + ); +} - if( ref $self->moniker_map eq 'HASH' ) { - $moniker = $self->moniker_map->{$table}; - } - elsif( ref $self->moniker_map eq 'CODE' ) { - $moniker = $self->moniker_map->($table); - } +sub _load_relationships { + my ($self, $tables) = @_; - $moniker ||= $self->_default_table2moniker($table); + my @tables; - return $moniker; -} + foreach my $table (@$tables) { + my $tbl_fk_info = $self->_table_fk_info($table); + foreach my $fkdef (@$tbl_fk_info) { + $fkdef->{remote_source} = + $self->monikers->{delete $fkdef->{remote_table}}; + } + my $tbl_uniq_info = $self->_table_uniq_info($table); -sub _load_relationships { - my ($self, $table) = @_; + my $local_moniker = $self->monikers->{$table}; - my $tbl_fk_info = $self->_table_fk_info($table); - foreach my $fkdef (@$tbl_fk_info) { - $fkdef->{remote_source} = - $self->monikers->{delete $fkdef->{remote_table}}; + push @tables, [ $local_moniker, $tbl_fk_info, $tbl_uniq_info ]; } - my $tbl_uniq_info = $self->_table_uniq_info($table); - my $local_moniker = $self->monikers->{$table}; - my $rel_stmts = $self->_relbuilder->generate_code($local_moniker, $tbl_fk_info, $tbl_uniq_info); + my $rel_stmts = $self->_relbuilder->generate_code(\@tables); foreach my $src_class (sort keys %$rel_stmts) { my $src_stmts = $rel_stmts->{$src_class}; @@ -1770,6 +2202,23 @@ sub _load_relationships { } } +sub _load_roles { + my ($self, $table) = @_; + + my $table_moniker = $self->monikers->{$table}; + my $table_class = $self->classes->{$table}; + + my @roles = @{ $self->result_roles || [] }; + push @roles, @{ $self->result_roles_map->{$table_moniker} } + if exists $self->result_roles_map->{$table_moniker}; + + if (@roles) { + $self->_pod_class_list($table_class, 'L ROLES APPLIED', @roles); + + $self->_with($table_class, @roles); + } +} + # Overload these in driver class: # Returns an arrayref of column names @@ -1807,6 +2256,36 @@ sub _dbic_stmt { return; } +sub _make_pod_heading { + my ($self, $class) = @_; + + return '' if not $self->generate_pod; + + my $table = $self->class_to_table->{$class}; + my $pod; + + my $pcm = $self->pod_comment_mode; + my ($comment, $comment_overflows, $comment_in_name, $comment_in_desc); + $comment = $self->__table_comment($table); + $comment_overflows = ($comment and length $comment > $self->pod_comment_spillover_length); + $comment_in_name = ($pcm eq 'name' or ($pcm eq 'auto' and !$comment_overflows)); + $comment_in_desc = ($pcm eq 'description' or ($pcm eq 'auto' and $comment_overflows)); + + $pod .= "=head1 NAME\n\n"; + + my $table_descr = $class; + $table_descr .= " - " . $comment if $comment and $comment_in_name; + + $pod .= "$table_descr\n\n"; + + if ($comment and $comment_in_desc) { + $pod .= "=head1 DESCRIPTION\n\n${comment}\n\n"; + } + $pod .= "=cut\n\n"; + + return $pod; +} + # generates the accompanying pod for a DBIC class method statement, # storing it with $self->_pod sub _make_pod { @@ -1814,25 +2293,13 @@ sub _make_pod { my $class = shift; my $method = shift; - if ( $method eq 'table' ) { - my ($table) = @_; - my $pcm = $self->pod_comment_mode; - my ($comment, $comment_overflows, $comment_in_name, $comment_in_desc); - $comment = $self->__table_comment($table); - $comment_overflows = ($comment and length $comment > $self->pod_comment_spillover_length); - $comment_in_name = ($pcm eq 'name' or ($pcm eq 'auto' and !$comment_overflows)); - $comment_in_desc = ($pcm eq 'description' or ($pcm eq 'auto' and $comment_overflows)); - $self->_pod( $class, "=head1 NAME" ); - my $table_descr = $class; - $table_descr .= " - " . $comment if $comment and $comment_in_name; - $self->{_class2table}{ $class } = $table; - $self->_pod( $class, $table_descr ); - if ($comment and $comment_in_desc) { - $self->_pod( $class, "=head1 DESCRIPTION" ); - $self->_pod( $class, $comment ); - } - $self->_pod_cut( $class ); - } elsif ( $method eq 'add_columns' ) { + if ($method eq 'table') { + my $table = $_[0]; + $table = $$table if ref $table eq 'SCALAR'; + $self->_pod($class, "=head1 TABLE: C<$table>"); + $self->_pod_cut($class); + } + elsif ( $method eq 'add_columns' ) { $self->_pod( $class, "=head1 ACCESSORS" ); my $col_counter = 0; my @cols = @_; @@ -1851,7 +2318,7 @@ sub _make_pod { " $_: $s" } sort keys %$attrs, ); - if (my $comment = $self->__column_comment($self->{_class2table}{$class}, $col_counter, $name)) { + if (my $comment = $self->__column_comment($self->class_to_table->{$class}, $col_counter, $name)) { $self->_pod( $class, $comment ); } } @@ -1865,6 +2332,64 @@ sub _make_pod { $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"); + } + + $self->_pod($class, '=back'); + $self->_pod_cut($class); + + $self->{_uniqs_started}{$class} = 1; + } + 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"); + } + + $self->_pod($class, '=back'); + $self->_pod_cut($class); + } +} + +sub _pod_class_list { + my ($self, $class, $title, @classes) = @_; + + return unless @classes && $self->generate_pod; + + $self->_pod($class, "=head1 $title"); + $self->_pod($class, '=over 4'); + + foreach my $link (@classes) { + $self->_pod($class, "=item * L<$link>"); + } + + $self->_pod($class, '=back'); + $self->_pod_cut($class); +} + +sub _base_class_pod { + my ($self, $base_class) = @_; + + return unless $self->generate_pod; + + return <<"EOF" +=head1 BASE CLASS: L<$base_class> + +=cut + +EOF } sub _filter_comment { @@ -1920,20 +2445,6 @@ sub _ext_stmt { push(@{$self->{_ext_storage}->{$class}}, $stmt); } -sub _quote_table_name { - my ($self, $table) = @_; - - my $qt = $self->schema->storage->sql_maker->quote_char; - - return $table unless $qt; - - if (ref $qt) { - return $qt->[0] . $table . $qt->[1]; - } - - return $qt . $table . $qt; -} - sub _custom_column_info { my ( $self, $table_name, $column_name, $column_info ) = @_; @@ -2017,6 +2528,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