X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FDBIx%2FClass%2FSchema%2FLoader%2FBase.pm;h=a2f1218770113fcddb2e2ceb5e5446a567380315;hb=refs%2Ftags%2F0.07013;hp=b42584bfb5774555a0f00741c5afbd93e797bc3e;hpb=5975bbe67547badcbf19b1eded170ca6beea301b;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 b42584b..a2f1218 100644 --- a/lib/DBIx/Class/Schema/Loader/Base.pm +++ b/lib/DBIx/Class/Schema/Loader/Base.pm @@ -24,12 +24,11 @@ use DBIx::Class::Schema::Loader::Optional::Dependencies (); use Try::Tiny; use DBIx::Class (); use Encode qw/encode decode/; -use List::MoreUtils qw/all firstidx/; -use IPC::Open2; -use Symbol 'gensym'; +use List::MoreUtils qw/all any firstidx uniq/; +use File::Temp 'tempfile'; use namespace::clean; -our $VERSION = '0.07010'; +our $VERSION = '0.07013'; __PACKAGE__->mk_group_ro_accessors('simple', qw/ schema @@ -59,6 +58,7 @@ __PACKAGE__->mk_group_ro_accessors('simple', qw/ result_base_class result_roles use_moose + only_autoclean overwrite_modifications relationship_attrs @@ -168,12 +168,26 @@ overwriting a dump made with an earlier version. The option also takes a hashref: - naming => { relationships => 'v7', monikers => 'v7' } + naming => { + relationships => 'v8', + monikers => 'v8', + column_accessors => 'v8', + force_ascii => 1, + } + +or + + naming => { ALL => 'v8', force_ascii => 1 } The keys are: =over 4 +=item ALL + +Set L, L and L to the specified +value. + =item relationships How to name relationship accessors. @@ -189,8 +203,8 @@ How to name column accessors in Result classes. =item force_ascii For L mode and later, uses L instead of -L to force monikers and other identifiers -such as relationship names to ASCII. +L to force monikers and other identifiers to +ASCII. =back @@ -243,9 +257,17 @@ breaking any of your code. The default mode is L, to get L mode, you have to specify it in L explictly until C<0.08> comes out. -L are created using L or -L if L is set; this is only significant -for table names with non C<\w> characters such as C<.>. +L and L are created using +L or L if +L is set; this is only significant for names with non-C<\w> +characters such as C<.>. + +CamelCase identifiers with words in all caps, e.g. C are supported +correctly in this mode. + +For relationships, belongs_to accessors are made from column names by stripping +postfixes other than C<_id> as well, for example just C, C<_?ref>, C<_?cd>, +C<_?code> and C<_?num>, case insensitively. =item preserve @@ -291,10 +313,11 @@ metadata for the text if available and supported. Comment metadata can be stored in two ways. The first is that you can create two tables named C and -C respectively. They both need to have columns named -C and C. The second one needs to have a column -named C. Then data stored in these tables will be used as a -source of metadata about tables and comments. +C respectively. These tables must exist in the same database +and schema as the tables they describe. They both need to have columns named +C and C. The second one needs to have a column named +C. Then data stored in these tables will be used as a source of +metadata about tables and comments. (If you wish you can change the name of these tables with the parameters L and L.) @@ -346,11 +369,17 @@ The default is C<60> The table to look for comments about tables in. By default C. See L for details. +This must not be a fully qualified name, the table will be looked for in the +same database and schema as the table whose comment is being retrieved. + =head2 column_comments_table The table to look for comments about columns in. By default C. See L for details. +This must not be a fully qualified name, the table will be looked for in the +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 @@ -386,8 +415,12 @@ keys and arrays of owners as values, set to the value: for all owners in all databases. -You may need to control naming of monikers with L if you have -name clashes for tables in different schemas/databases. +Name clashes resulting from the same table name in different databases/schemas +will be resolved automatically by prefixing the moniker with the database +and/or schema. + +To prefix/suffix all monikers with the database and/or schema, see +L. =head2 moniker_parts @@ -431,12 +464,12 @@ Exclude tables matching regex. Best specified as a qr// regex. =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 single scalar table name argument and returning -a scalar moniker. 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. +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 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 +value, the code falls back to default behavior for that table name. The default behavior is to split on case transition and non-alphanumeric boundaries, singularize the resulting phrase, then join the titlecased words @@ -460,11 +493,14 @@ passed, the code is called with arguments of { 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, + table => table object of interface DBIx::Class::Schema::Loader::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), - } + } + +the L
stringifies to the +unqualified table name. =head2 rel_name_map @@ -519,6 +555,10 @@ Default behavior is to utilize L. Base class for your schema classes. Defaults to 'DBIx::Class::Schema'. +=head2 schema_components + +List of components to load into the Schema class. + =head2 result_base_class Base class for your table classes (aka result classes). Defaults to @@ -537,10 +577,6 @@ that need to be leftmost. List of additional classes which all of your table classes will use. -=head2 schema_components - -List of components to load into the Schema class. - =head2 components List of additional components to be loaded into all of your Result @@ -655,12 +691,13 @@ L for a column. Must be a coderef that returns a hashref with the extra attributes. -Receives the table name, column name and column_info. +Receives the L
(which +stringifies to the unqualified table name), column name and column_info. For example: custom_column_info => sub { - my ($table_name, $column_name, $column_info) = @_; + my ($table, $column_name, $column_info) = @_; if ($column_name eq 'dog' && $column_info->{default_value} eq 'snoopy') { return { is_snoopy => 1 }; @@ -696,29 +733,48 @@ loader options. =head2 preserve_case -Usually column names are lowercased, to make them easier to work with in -L. This option lets you turn this behavior off, if the driver -supports it. +Normally database names are lowercased and split by underscore, use this option +if you have CamelCase database names. Drivers for case sensitive databases like Sybase ASE or MSSQL with a case-sensitive collation will turn this option on unconditionally. -Currently the drivers for SQLite, mysql, MSSQL and Firebird/InterBase support -setting this option. +B L = C is highly recommended with this option as the +semantics of this mode are much improved for CamelCase database names. + +L = C or greater is required with this option. =head2 qualify_objects Set to true to prepend the L to table names for C<< __PACKAGE__->table >> calls, and to some other things like Oracle sequences. +This attribute is automatically set to true for multi db_schema configurations. + =head2 use_moose Creates Schema and Result classes that use L, L and -L. The default content after the md5 sum also makes the -classes immutable. +L (or L, see below). The default +content after the md5 sum also makes the classes immutable. It is safe to upgrade your existing Schema to this option. +=head2 only_autoclean + +By default, we use L to remove imported functions from +your generated classes. It uses L to do this, after +telling your object's metaclass that any operator Ls in your class +are methods, which will cause namespace::autoclean to spare them from removal. + +This prevents the "Hey, where'd my overloads go?!" effect. + +If you don't care about operator overloads, enabling this option falls back to +just using L itself. + +If none of the above made any sense, or you don't have some pressing need to +only use L, leaving this set to the default is +recommended. + =head2 col_collision_map This option controls how accessors for column names which collide with perl @@ -935,10 +991,16 @@ sub new { column_accessors => $naming_ver, }; } + elsif (ref $self->naming eq 'HASH' && exists $self->naming->{ALL}) { + my $val = delete $self->naming->{ALL}; + + $self->naming->{$_} = $val + foreach qw/relationships monikers column_accessors/; + } if ($self->naming) { - for (values %{ $self->naming }) { - $_ = $CURRENT_V if $_ eq 'current'; + foreach my $key (qw/relationships monikers column_accessors/) { + $self->naming->{$key} = $CURRENT_V if ($self->naming->{$key}||'') eq 'current'; } } $self->{naming} ||= {}; @@ -1398,59 +1460,110 @@ sub _relbuilder { return if $self->{skip_relationships}; return $self->{relbuilder} ||= do { - - no warnings 'uninitialized'; my $relbuilder_suff = {qw{ v4 ::Compat::v0_040 v5 ::Compat::v0_05 v6 ::Compat::v0_06 + v7 ::Compat::v0_07 }} - ->{ $self->naming->{relationships}}; + ->{$self->naming->{relationships}||$CURRENT_V} || ''; my $relbuilder_class = 'DBIx::Class::Schema::Loader::RelBuilder'.$relbuilder_suff; $self->ensure_class_loaded($relbuilder_class); - $relbuilder_class->new( $self ); - + $relbuilder_class->new($self); }; } sub _load_tables { my ($self, @tables) = @_; - # Save the new tables to the tables list + # Save the new tables to the tables list and compute monikers foreach (@tables) { - $self->_tables->{$_->sql_name} = $_; + $self->_tables->{$_->sql_name} = $_; + $self->monikers->{$_->sql_name} = $self->_table2moniker($_); } - $self->_make_src_class($_) for @tables; - - # sanity-check for moniker clashes + # check for moniker clashes my $inverse_moniker_idx; foreach my $table (values %{ $self->_tables }) { - push @{ $inverse_moniker_idx->{$self->monikers->{$table->sql_name}} }, $table; + push @{ $inverse_moniker_idx->{$self->monikers->{$table->sql_name}} }, $table; } my @clashes; foreach my $moniker (keys %$inverse_moniker_idx) { - my $tables = $inverse_moniker_idx->{$moniker}; - if (@$tables > 1) { - push @clashes, sprintf ("tables %s reduced to the same source moniker '%s'", - join (', ', map $_->sql_name, @$tables), - $moniker, - ); - } + my $tables = $inverse_moniker_idx->{$moniker}; + if (@$tables > 1) { + my $different_databases = + $tables->[0]->can('database') && (uniq map $_->database||'', @$tables) > 1; + + my $different_schemas = + (uniq map $_->schema||'', @$tables) > 1; + + if ($different_databases || $different_schemas) { + my ($use_schema, $use_database) = (1, 0); + + if ($different_databases) { + $use_database = 1; + + # If any monikers are in the same database, we have to distinguish by + # both schema and database. + my %db_counts; + $db_counts{$_}++ for map $_->database, @$tables; + $use_schema = any { $_ > 1 } values %db_counts; + } + + delete $self->monikers->{$_->sql_name} for @$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 }; + + unshift @$moniker_parts, 'schema' if $use_schema && !$have_schema; + unshift @$moniker_parts, 'database' if $use_database && !$have_database; + + local $self->{moniker_parts} = $moniker_parts; + + my %new_monikers; + + $new_monikers{$_->sql_name} = $self->_table2moniker($_) for @$tables; + + $self->monikers->{$_} = $new_monikers{$_} for map $_->sql_name, @$tables; + + # check if there are still clashes + my %by_moniker; + + while (my ($t, $m) = each %new_monikers) { + push @{ $by_moniker{$m} }, $t; + } + + foreach my $m (grep @{ $by_moniker{$_} } > 1, keys %by_moniker) { + push @clashes, sprintf ("tried disambiguating by moniker_parts, but tables %s still reduced to the same source moniker '%s'", + join (', ', @{ $by_moniker{$m} }), + $m, + ); + } + } + else { + push @clashes, sprintf ("tables %s reduced to the same source moniker '%s'", + join (', ', map $_->sql_name, @$tables), + $moniker, + ); + } + } } if (@clashes) { - die 'Unable to load schema - chosen moniker/class naming style results in moniker clashes. ' - . 'In multi db_schema configurations you may need to set moniker_parts, ' - . 'otherwise change the naming style, or supply an explicit moniker_map: ' - . join ('; ', @clashes) - . "\n" - ; + die 'Unable to load schema - chosen moniker/class naming style results in moniker clashes. ' + . 'Change the naming style, or supply an explicit moniker_map: ' + . join ('; ', @clashes) + . "\n" + ; } + $self->_make_src_class($_) for @tables; + $self->_setup_src_meta($_) for @tables; if(!$self->skip_relationships) { @@ -1619,8 +1732,15 @@ sub _dump_to_dir { . qq|# Created by DBIx::Class::Schema::Loader\n| . qq|# DO NOT MODIFY THE FIRST PART OF THIS FILE\n\n|; + my $autoclean + = $self->only_autoclean + ? 'namespace::autoclean' + : 'MooseX::MarkAsMethods autoclean => 1' + ; + if ($self->use_moose) { - $schema_text.= qq|use Moose;\nuse namespace::autoclean;\nextends '$schema_base_class';\n\n|; + + $schema_text.= qq|use Moose;\nuse $autoclean;\nextends '$schema_base_class';\n\n|; } else { $schema_text .= qq|use strict;\nuse warnings;\n\nuse base '$schema_base_class';\n\n|; @@ -1678,7 +1798,7 @@ sub _dump_to_dir { unless $result_base_class eq 'DBIx::Class::Core'; if ($self->use_moose) { - $src_text.= qq|use Moose;\nuse MooseX::NonMoose;\nuse namespace::autoclean;|; + $src_text.= qq|use Moose;\nuse MooseX::NonMoose;\nuse $autoclean;|; # these options 'use base' which is compile time if (@{ $self->left_base_classes } || @{ $self->additional_base_classes }) { @@ -1745,17 +1865,13 @@ sub _write_classfile { my $custom_content = $old_custom || ''; - # prepend extra custom content from a *renamed* class (singularization effect) + # Use custom content from a renamed class, the class names in it are + # rewritten below. if (my $renamed_class = $self->_upgrading_classes->{$class}) { my $old_filename = $self->_get_dump_filename($renamed_class); if (-f $old_filename) { - my $extra_custom = ($self->_parse_generated_file ($old_filename))[4]; - - $extra_custom =~ s/\n\n# You can replace.*\n1;\n//; - - $custom_content = join ("\n", '', $extra_custom, $custom_content) - if $extra_custom; + $custom_content = ($self->_parse_generated_file ($old_filename))[4]; unlink $old_filename; } @@ -1800,23 +1916,26 @@ sub _write_classfile { ); } else { - my ($out, $in) = (gensym, gensym); + my ($fh, $temp_file) = tempfile(); - my $pid = open2($out, $in, $filter) - or croak "Could not open pipe to $filter: $!"; - - print $in $text; + binmode $fh, ':encoding(UTF-8)'; + print $fh $text; + close $fh; - close $in; + open my $out, qq{$filter < "$temp_file"|} + or croak "Could not open pipe to $filter: $!"; $text = decode('UTF-8', do { local $/; <$out> }); $text =~ s/$CR?$LF/\n/g; - waitpid $pid, 0; + close $out; my $exit_code = $? >> 8; + unlink $temp_file + or croak "Could not remove temporary file '$temp_file': $!"; + if ($exit_code != 0) { croak "filter '$filter' exited non-zero: $exit_code"; } @@ -1981,7 +2100,7 @@ sub _make_src_class { my $schema = $self->schema; my $schema_class = $self->schema_class; - my $table_moniker = $self->_table2moniker($table); + my $table_moniker = $self->monikers->{$table->sql_name}; my @result_namespace = ($schema_class); if ($self->use_namespaces) { my $result_namespace = $self->result_namespace || 'Result'; @@ -2026,7 +2145,6 @@ sub _make_src_class { } $self->classes->{$table->sql_name} = $table_class; - $self->monikers->{$table->sql_name} = $table_moniker; $self->moniker_to_table->{$table_moniker} = $table; $self->class_to_table->{$table_class} = $table; @@ -2155,18 +2273,27 @@ sub _run_user_map { sub _default_column_accessor_name { my ( $self, $column_name ) = @_; - my $accessor_name = $column_name; - $accessor_name =~ s/\W+/_/g; + my $preserve = ($self->naming->{column_accessors}||'') eq 'preserve'; + + my $v = $self->_get_naming_v('column_accessors'); - if ((($self->naming->{column_accessors}||'') =~ /(\d+)/ && $1 < 7) || (not $self->preserve_case)) { + my $accessor_name = $preserve ? + $self->_to_identifier('column_accessors', $column_name) # assume CamelCase + : + $self->_to_identifier('column_accessors', $column_name, '_'); + + $accessor_name =~ s/\W+/_/g; # only if naming < v8, otherwise to_identifier + # takes care of it + + if ($preserve) { + return $accessor_name; + } + elsif ($v < 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; + return join '_', map lc, split_name $column_name, $v; } sub _make_column_accessor_name { @@ -2315,34 +2442,60 @@ sub tables { return values %{$self->_tables}; } +sub _get_naming_v { + my ($self, $naming_key) = @_; + + my $v; + + if (($self->naming->{$naming_key}||'') =~ /^v(\d+)\z/) { + $v = $1; + } + else { + ($v) = $CURRENT_V =~ /^v(\d+)\z/; + } + + return $v; +} + +sub _to_identifier { + my ($self, $naming_key, $name, $sep_char, $force) = @_; + + my $v = $self->_get_naming_v($naming_key); + + my $to_identifier = $self->naming->{force_ascii} ? + \&String::ToIdentifier::EN::to_identifier + : \&String::ToIdentifier::EN::Unicode::to_identifier; + + return $v >= 8 || $force ? $to_identifier->($name, $sep_char) : $name; +} + # Make a moniker from a table sub _default_table2moniker { my ($self, $table) = @_; - my ($v) = ($self->naming->{monikers}||$CURRENT_V) =~ /^v(\d+)\z/; + my $v = $self->_get_naming_v('monikers'); my @name_parts = map $table->$_, @{ $self->moniker_parts }; my $name_idx = firstidx { $_ eq 'name' } @{ $self->moniker_parts }; - my $to_identifier = $self->naming->{force_ascii} ? - \&String::ToIdentifier::EN::to_identifier - : \&String::ToIdentifier::EN::Unicode::to_identifier; - my @all_parts; foreach my $i (0 .. $#name_parts) { my $part = $name_parts[$i]; - if ($i != $name_idx || $v > 7) { - $part = $to_identifier->($part, '_'); + if ($i != $name_idx || $v >= 8) { + $part = $self->_to_identifier('monikers', $part, '_', 1); } if ($i == $name_idx && $v == 5) { $part = Lingua::EN::Inflect::Number::to_S($part); } - my @part_parts = map lc, $v > 6 ? split_name $part : split /[\W_]+/, $part; + my @part_parts = map lc, $v > 6 ? + # use v8 semantics for all moniker parts except name + ($i == $name_idx ? split_name $part, $v : split_name $part) + : split /[\W_]+/, $part; if ($i == $name_idx && $v >= 6) { my $as_phrase = join ' ', @part_parts; @@ -2725,7 +2878,7 @@ If you use the loader on a database with table and column names in a language other than English, you will want to turn off the English language specific heuristics. -To do so, use something like this in your laoder options: +To do so, use something like this in your loader options: naming => { monikers => 'v4' }, inflect_singular => sub { "$_[0]_rel" }, @@ -2760,7 +2913,7 @@ You can also control the renaming with the L option. =head1 SEE ALSO -L +L, L =head1 AUTHOR