X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FDBIx%2FClass%2FSchema%2FLoader%2FBase.pm;h=19946377ddf95c4256a6bf4ba5562e2d3a88ffe5;hb=8a9cc3bb69bee00efb91480ed7106a9bdf473414;hp=e854e5112d8cab021ce28d09cc49cdc254e05ee5;hpb=7dc01f79973f1c9fd78f713b8c5e0d001358cded;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 e854e51..1994637 100644 --- a/lib/DBIx/Class/Schema/Loader/Base.pm +++ b/lib/DBIx/Class/Schema/Loader/Base.pm @@ -3,31 +3,33 @@ package DBIx::Class::Schema::Loader::Base; use strict; use warnings; use base qw/Class::Accessor::Grouped Class::C3::Componentised/; +use MRO::Compat; use mro 'c3'; use Carp::Clan qw/^DBIx::Class/; -use DBIx::Class::Schema::Loader::RelBuilder; -use Data::Dump qw/ dump /; -use POSIX qw//; -use File::Spec qw//; -use Cwd qw//; -use Digest::MD5 qw//; -use Lingua::EN::Inflect::Number qw//; -use Lingua::EN::Inflect::Phrase qw//; -use File::Temp qw//; +use DBIx::Class::Schema::Loader::RelBuilder (); +use Data::Dump 'dump'; +use POSIX (); +use File::Spec (); +use Cwd (); +use Digest::MD5 (); +use Lingua::EN::Inflect::Number (); +use Lingua::EN::Inflect::Phrase (); +use String::ToIdentifier::EN (); +use String::ToIdentifier::EN::Unicode (); +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/; use DBIx::Class::Schema::Loader::Optional::Dependencies (); use Try::Tiny; use DBIx::Class (); use Encode qw/encode decode/; -use List::MoreUtils 'all'; -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.07037'; __PACKAGE__->mk_group_ro_accessors('simple', qw/ schema @@ -57,11 +59,11 @@ __PACKAGE__->mk_group_ro_accessors('simple', qw/ result_base_class result_roles use_moose + only_autoclean overwrite_modifications relationship_attrs - db_schema _tables classes _upgrading_classes @@ -72,11 +74,10 @@ __PACKAGE__->mk_group_ro_accessors('simple', qw/ datetime_locale config_file loader_class - qualify_objects - tables table_comments_table column_comments_table class_to_table + moniker_to_table uniq_to_primary quiet /); @@ -105,6 +106,11 @@ __PACKAGE__->mk_group_accessors('simple', qw/ _result_class_methods naming_set filter_generated_code + db_schema + qualify_objects + moniker_parts + moniker_part_separator + moniker_part_map /); my $CURRENT_V = 'v7'; @@ -125,7 +131,7 @@ DBIx::Class::Schema::Loader::Base - Base DBIx::Class::Schema::Loader Implementat =head1 SYNOPSIS -See L +See L. =head1 DESCRIPTION @@ -165,12 +171,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. @@ -183,6 +203,12 @@ How to name Result classes. 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 to +ASCII. + =back The values can be: @@ -216,16 +242,32 @@ In general, there is very little difference between v5 and v6 schemas. =item v7 This mode is identical to C mode, except that monikerization of CamelCase -table names is also done correctly. +table names is also done better (but best in v8.) -CamelCase column names in case-preserving mode will also be handled correctly -for relationship name inflection. See L. +CamelCase column names in case-preserving mode will also be handled better +for relationship name inflection (but best in v8.) See L. In this mode, CamelCase L are normalized based on case 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 v8 + +(EXPERIMENTAL) + +The default mode is L, to get L mode, you have to specify it in +L explicitly until C<0.08> comes out. + +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 @@ -271,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.) @@ -326,25 +369,116 @@ 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 -by type. Also supports relationship type 'all', containing options to -pass to all generated relationships. Attributes set for more specific -relationship types override those set in 'all'. +Hashref of attributes to pass to each generated relationship, listed by type. +Also supports relationship type 'all', containing options to pass to all +generated relationships. Attributes set for more specific relationship types +override those set in 'all', and any attributes specified by this option +override the introspected attributes of the foreign key if any. For example: relationship_attrs => { - belongs_to => { is_deferrable => 0 }, + has_many => { cascade_delete => 1, cascade_copy => 1 }, + might_have => { cascade_delete => 1, cascade_copy => 1 }, }, -use this to turn off DEFERRABLE on your foreign key constraints. +use this to turn L cascades to on on your +L and +L relationships, they default +to off. + +Can also be a coderef, for more precise control, in which case the coderef gets +this hash of parameters (as a list:) + + rel_name # the name of the relationship + rel_type # the type of the relationship: 'belongs_to', 'has_many' or 'might_have' + local_source # the DBIx::Class::ResultSource object for the source the rel is *from* + remote_source # the DBIx::Class::ResultSource object for the source the rel is *to* + local_table # a DBIx::Class::Schema::Loader::Table object for the table of the source the rel is from + local_cols # an arrayref of column names of columns used in the rel in the source it is from + remote_table # a DBIx::Class::Schema::Loader::Table object for the table of the source the rel is to + remote_cols # an arrayref of column names of columns used in the rel in the source it is to + attrs # the attributes that would be set + +it should return the new hashref of attributes, or nothing for no changes. + +For example: + + relationship_attrs => sub { + my %p = @_; + + say "the relationship name is: $p{rel_name}"; + say "the relationship is a: $p{rel_type}"; + say "the local class is: ", $p{local_source}->result_class; + say "the remote class is: ", $p{remote_source}->result_class; + say "the local table is: ", $p{local_table}->sql_name; + say "the rel columns in the local table are: ", (join ", ", @{$p{local_cols}}); + say "the remote table is: ", $p{remote_table}->sql_name; + say "the rel columns in the remote table are: ", (join ", ", @{$p{remote_cols}}); + + if ($p{local_table} eq 'dogs' && @{$p{local_cols}} == 1 && $p{local_cols}[0] eq 'name') { + $p{attrs}{could_be_snoopy} = 1; + + reutrn $p{attrs}; + } + }, + +These are the default attributes: + + has_many => { + cascade_delete => 0, + cascade_copy => 0, + }, + might_have => { + cascade_delete => 0, + cascade_copy => 0, + }, + belongs_to => { + on_delete => 'CASCADE', + on_update => 'CASCADE', + is_deferrable => 1, + }, + +For L relationships, these +defaults are overridden by the attributes introspected from the foreign key in +the database, if this information is available (and the driver is capable of +retrieving it.) + +This information overrides the defaults mentioned above, and is then itself +overridden by the user's L for C if any are +specified. + +In general, for most databases, for a plain foreign key with no rules, the +values for a L relationship +will be: + + on_delete => 'NO ACTION', + on_update => 'NO ACTION', + is_deferrable => 0, + +In the cases where an attribute is not supported by the DB, a value matching +the actual behavior is used, for example Oracle does not support C +rules, so C is set to C. This is done so that the +behavior of the schema is preserved when cross deploying to a different RDBMS +such as SQLite for testing. + +In the cases where the DB does not support C foreign keys, the +value is set to C<1> if L has a working C<< +$storage->with_deferred_fk_checks >>. This is done so that the same +L code can be used, and cross deployed from and to such databases. =head2 debug @@ -354,25 +488,125 @@ 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. + +For MSSQL, Sybase ASE, and Informix can be set to a hashref of databases as +keys and arrays of owners as values, set to the value: + + { '%' => '%' } + +for all owners in all 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 + +The database table names are represented by the +L class in the loader, the +L class for Sybase ASE and +L for Informix. + +Monikers are created normally based on just the +L property, corresponding to +the table name, but can consist of other parts of the fully qualified name of +the table. + +The L 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. + +The C<'name'> entry B be present. + +Below is a table of supported databases and possible L. + +=over 4 + +=item * DB2, Firebird, mysql, Oracle, Pg, SQLAnywhere, SQLite, MS Access + +C, C + +=item * Informix, MSSQL, Sybase ASE + +C, C, C + +=back + +=head2 moniker_part_separator + +String used to join L 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 +form), or as an arrayref of arrayrefs. Regexes are matched against +the (unqualified) table name, while arrayrefs are matched according to +L. + +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 and C in C and +C in C 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 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. Either + +=over + +=item * + +a nested hashref, which will be traversed according to L + +For example: + + moniker_parts => [qw(schema name)], + moniker_map => { + foo => { + bar => "FooishBar", + }, + }, + +In which case the table C in the C schema would get the moniker +C. + +=item * + +a hashref of unqualified table name keys and moniker values + +=item * + +a coderef for a translator function taking a L argument (which stringifies to the +unqualified table name) and returning a scalar moniker + +=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 boundaries, singularize the resulting phrase, then join the titlecased words @@ -386,6 +620,25 @@ together. Examples: stations_visited | StationVisited routeChange | RouteChange +=head2 moniker_part_map + +Map for overriding the monikerization of individual L. +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, the code ref would be called with the +arguments C and C. + +L takes precedence over this. + =head2 col_accessor_map Same as moniker_map, but for column accessor names. If a coderef is @@ -396,11 +649,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 @@ -435,6 +691,10 @@ If it is a coderef, the argument passed will be a hashref of this form: 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, + # for type => "many_to_many" only: + link_class => name of the DBIC class for the link table + link_moniker => moniker of the DBIC class for the link table + link_rel_name => name of the relationship to the link table } DBICSL will try to use the value returned as the relationship name. @@ -455,6 +715,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 @@ -473,10 +737,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 @@ -496,7 +756,7 @@ load certain components for specified Result classes. For example: 'InflateColumn::DateTime', ], } - + You may use this in conjunction with L. =head2 result_roles @@ -516,7 +776,7 @@ certain roles for specified Result classes. For example: ], RouteChange => 'YourApp::Role::TripEvent', } - + You may use this in conjunction with L. =head2 use_namespaces @@ -591,12 +851,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 }; @@ -632,29 +893,49 @@ 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, +unless explicitly set to false by the user. + =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 @@ -714,7 +995,7 @@ L. =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; @@ -767,7 +1048,7 @@ sub new { } $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"; @@ -827,8 +1108,9 @@ sub new { } } + $self->{_tables} = {}; $self->{monikers} = {}; - $self->{tables} = {}; + $self->{moniker_to_table} = {}; $self->{class_to_table} = {}; $self->{classes} = {}; $self->{_upgrading_classes} = {}; @@ -870,10 +1152,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} ||= {}; @@ -925,7 +1213,47 @@ sub new { } } - $self; + if (defined $self->db_schema) { + if (ref $self->db_schema eq 'ARRAY') { + if (@{ $self->db_schema } > 1 && not defined $self->{qualify_objects}) { + $self->{qualify_objects} = 1; + } + elsif (@{ $self->db_schema } == 0) { + $self->{db_schema} = undef; + } + } + elsif (not ref $self->db_schema) { + if ($self->db_schema eq '%' && not defined $self->{qualify_objects}) { + $self->{qualify_objects} = 1; + } + + $self->{db_schema} = [ $self->db_schema ]; + } + } + + if (not $self->moniker_parts) { + $self->moniker_parts(['name']); + } + else { + if (not ref $self->moniker_parts) { + $self->moniker_parts([ $self->moniker_parts ]); + } + if (ref $self->moniker_parts ne 'ARRAY') { + croak 'moniker_parts must be an arrayref'; + } + if ((firstidx { $_ eq 'name' } @{ $self->moniker_parts }) == -1) { + 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; } sub _check_back_compat { @@ -1093,7 +1421,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; } @@ -1116,8 +1444,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)) }) || ''); } @@ -1270,16 +1600,16 @@ sub rescan { my @current = $self->_tables_list({ constraint => $self->constraint, exclude => $self->exclude }); foreach my $table (@current) { - if(!exists $self->{_tables}->{$table}) { + if(!exists $self->_tables->{$table->sql_name}) { push(@created, $table); } } my %current; - @current{@current} = (); - foreach my $table (keys %{ $self->{_tables} }) { - if (not exists $current{$table}) { - $self->_unregister_source_for_table($table); + @current{map $_->sql_name, @current} = (); + foreach my $table (values %{ $self->_tables }) { + if (not exists $current{$table->sql_name}) { + $self->_remove_table($table); } } @@ -1287,7 +1617,11 @@ sub rescan { my $loaded = $self->_load_tables(@current); - return map { $self->monikers->{$_} } @created; + foreach my $table (@created) { + $self->monikers->{$table->sql_name} = $self->_table2moniker($table); + } + + return map { $self->monikers->{$_->sql_name} } @created; } sub _relbuilder { @@ -1296,60 +1630,109 @@ 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}->{$_} = 1; + $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; - for (keys %{$self->monikers}) { - push @{$inverse_moniker_idx->{$self->monikers->{$_}}}, $_; + foreach my $imtable (values %{ $self->_tables }) { + push @{ $inverse_moniker_idx->{$self->monikers->{$imtable->sql_name}} }, $imtable; } my @clashes; - for (keys %$inverse_moniker_idx) { - my $tables = $inverse_moniker_idx->{$_}; - if (@$tables > 1) { - push @clashes, sprintf ("tables %s reduced to the same source moniker '%s'", - join (', ', map { "'$_'" } @$tables), - $_, - ); - } + foreach my $moniker (keys %$inverse_moniker_idx) { + my $imtables = $inverse_moniker_idx->{$moniker}; + if (@$imtables > 1) { + my $different_databases = + $imtables->[0]->can('database') && (uniq map $_->database||'', @$imtables) > 1; + + my $different_schemas = + (uniq map $_->schema||'', @$imtables) > 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, @$imtables; + $use_schema = any { $_ > 1 } values %db_counts; + } + + foreach my $tbl (@$imtables) { delete $self->monikers->{$tbl->sql_name}; } + + my $moniker_parts = [ @{ $self->moniker_parts } ]; + + my $have_schema = any { $_ eq 'schema' } @{ $self->moniker_parts }; + my $have_database = 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; + + foreach my $tbl (@$imtables) { $new_monikers{$tbl->sql_name} = $self->_table2moniker($tbl); } + foreach my $name (map $_->sql_name, @$imtables) { $self->monikers->{$name} = $new_monikers{$name}; } + + # 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, @$imtables), + $moniker, + ); + } + } } if (@clashes) { - die 'Unable to load schema - chosen moniker/class naming style results in moniker clashes. ' - . 'Either 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->_setup_src_meta($_) for @tables; + foreach my $tbl (@tables) { $self->_make_src_class($tbl); } + foreach my $tbl (@tables) { $self->_setup_src_meta($tbl); } if(!$self->skip_relationships) { # The relationship loader needs a working schema @@ -1362,10 +1745,8 @@ sub _load_tables { @INC = grep $_ ne $self->dump_directory, @INC; } - $self->_load_roles($_) for @tables; - - $self->_load_external($_) - for map { $self->classes->{$_} } @tables; + foreach my $tbl (@tables) { $self->_load_roles($tbl); } + foreach my $tbl (map { $self->classes->{$_->sql_name} } @tables) { $self->_load_external($tbl); } # Reload without unloading first to preserve any symbols from external # packages. @@ -1388,18 +1769,18 @@ sub _reload_classes { # so that we don't repeat custom sections @INC = grep $_ ne $self->dump_directory, @INC; - $self->_dump_to_dir(map { $self->classes->{$_} } @tables); + $self->_dump_to_dir(map { $self->classes->{$_->sql_name} } @tables); unshift @INC, $self->dump_directory; - + my @to_register; my %have_source = map { $_ => $self->schema->source($_) } $self->schema->sources; for my $table (@tables) { - my $moniker = $self->monikers->{$table}; - my $class = $self->classes->{$table}; - + my $moniker = $self->monikers->{$table->sql_name}; + my $class = $self->classes->{$table->sql_name}; + { no warnings 'redefine'; local *Class::C3::reinitialize = sub {}; # to speed things up, reinitialized below @@ -1512,12 +1893,20 @@ sub _dump_to_dir { unless $self->dynamic or $self->quiet; my $schema_text = - qq|package $schema_class;\n\n| + qq|use utf8;\n| + . qq|package $schema_class;\n\n| . 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|; @@ -1561,8 +1950,9 @@ sub _dump_to_dir { my $result_base_class = $self->result_base_class || 'DBIx::Class::Core'; foreach my $src_class (@classes) { - my $src_text = - qq|package $src_class;\n\n| + my $src_text = + qq|use utf8;\n| + . 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|; @@ -1574,7 +1964,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 }) { @@ -1609,14 +1999,13 @@ sub _dump_to_dir { } warn "Schema dump completed.\n" unless $self->dynamic or $self->quiet; - } sub _sig_comment { my ($self, $version, $ts) = @_; return qq|\n\n# Created by DBIx::Class::Schema::Loader| . qq| v| . $version - . q| @ | . $ts + . q| @ | . $ts . qq|\n# DO NOT MODIFY THIS OR ANYTHING ABOVE! md5sum:|; } @@ -1642,17 +2031,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; } @@ -1697,23 +2082,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"; } @@ -1762,7 +2150,7 @@ sub _default_moose_custom_content { if (not $is_schema) { return qq|\n__PACKAGE__->meta->make_immutable;|; } - + return qq|\n__PACKAGE__->meta->make_immutable(inline_constructor => 0);|; } @@ -1878,7 +2266,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'; @@ -1911,16 +2299,19 @@ sub _make_src_class { ); } - my $old_class = join(q{::}, @result_namespace, - $self->_table2moniker($table)); + my $old_table_moniker = do { + local $self->naming->{monikers} = $upgrading_v; + $self->_table2moniker($table); + }; + + my $old_class = join(q{::}, @result_namespace, $old_table_moniker); $self->_upgrading_classes->{$table_class} = $old_class unless $table_class eq $old_class; } - $self->classes->{$table} = $table_class; - $self->monikers->{$table} = $table_moniker; - $self->tables->{$table_moniker} = $table; + $self->classes->{$table->sql_name} = $table_class; + $self->moniker_to_table->{$table_moniker} = $table; $self->class_to_table->{$table_class} = $table; $self->_pod_class_list($table_class, 'ADDITIONAL CLASSES USED', @{$self->additional_classes}); @@ -1953,9 +2344,9 @@ sub _make_src_class { } sub _is_result_class_method { - my ($self, $name, $table_name) = @_; + my ($self, $name, $table) = @_; - my $table_moniker = $table_name ? $self->monikers->{$table_name} : ''; + my $table_moniker = $table ? $self->monikers->{$table->sql_name} : ''; $self->_result_class_methods({}) if not defined $self->_result_class_methods; @@ -1999,14 +2390,12 @@ sub _is_result_class_method { sub _resolve_col_accessor_collisions { my ($self, $table, $col_info) = @_; - 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 ($self->_is_result_class_method($accessor, $table_name)) { + if ($self->_is_result_class_method($accessor, $table)) { my $mapped = 0; if (my $map = $self->col_collision_map) { @@ -2020,7 +2409,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; @@ -2036,7 +2425,23 @@ 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 ); @@ -2050,18 +2455,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 { @@ -2077,16 +2491,9 @@ sub _make_column_accessor_name { 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}"; +sub _table_is_view { + #my ($self, $table) = @_; + return 0; } # Set up metadata (cols, pks, etc) @@ -2096,26 +2503,13 @@ sub _setup_src_meta { my $schema = $self->schema; my $schema_class = $self->schema_class; - my $table_class = $self->classes->{$table}; - my $table_moniker = $self->monikers->{$table}; - - my $table_name = $table; - - 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); - } + my $table_class = $self->classes->{$table->sql_name}; + my $table_moniker = $self->monikers->{$table->sql_name}; - my $full_table_name = ($self->qualify_objects ? - ($self->_quote($self->db_schema) . '.') : '') - . (ref $table_name ? $$table_name : $table_name); + $self->_dbic_stmt($table_class, 'table_class', 'DBIx::Class::ResultSource::View') + if $self->_table_is_view($table); - # be careful to not create refs Data::Dump can "optimize" - $full_table_name = \do {"".$full_table_name} if ref $table_name; - - $self->_dbic_stmt($table_class, 'table', $full_table_name); + $self->_dbic_stmt($table_class, 'table', $table->dbic_name); my $cols = $self->_table_columns($table); my $col_info = $self->__columns_info_for($table); @@ -2127,8 +2521,9 @@ sub _setup_src_meta { my $context = { table_class => $table_class, table_moniker => $table_moniker, - table_name => $table_name, - full_table_name => $full_table_name, + table_name => $table, # bugwards compatibility, RT#84050 + table => $table, + full_table_name => $table->dbic_name, schema_class => $schema_class, column_info => $info, }; @@ -2200,6 +2595,10 @@ sub _setup_src_meta { $self->_dbic_stmt($table_class, 'set_primary_key', @$pks) if @$pks; + # Sort unique constraints by constraint name for repeatable results (rels + # are sorted as well elsewhere.) + @uniqs = sort { $a->[0] cmp $b->[0] } @uniqs; + foreach my $uniq (@uniqs) { my ($name, $cols) = @$uniq; $self->_dbic_stmt($table_class,'add_unique_constraint', $name, $cols); @@ -2231,40 +2630,93 @@ names. sub tables { my $self = shift; - return keys %{$self->_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 { - no warnings 'uninitialized'; my ($self, $table) = @_; - if ($self->naming->{monikers} eq 'v4') { - return join '', map ucfirst, split /[\W_]+/, lc $table; - } - elsif ($self->naming->{monikers} eq 'v5') { - return join '', map ucfirst, split /[\W_]+/, - Lingua::EN::Inflect::Number::to_S(lc $table); - } - elsif ($self->naming->{monikers} eq 'v6') { - (my $as_phrase = lc $table) =~ s/_+/ /g; - my $inflected = Lingua::EN::Inflect::Phrase::to_S($as_phrase); + my $v = $self->_get_naming_v('monikers'); - return join '', map ucfirst, split /\W+/, $inflected; - } + my @moniker_parts = @{ $self->moniker_parts }; + my @name_parts = map $table->$_, @moniker_parts; - my @words = map lc, split_name $table; - my $as_phrase = join ' ', @words; + my $name_idx = firstidx { $_ eq 'name' } @{ $self->moniker_parts }; - 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); + my @all_parts; + + foreach my $i (0 .. $#name_parts) { + my $part = $name_parts[$i]; - return join '', map ucfirst, split /\W+/, $inflected; + 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); + } + + if ($i == $name_idx && $v == 5) { + $part = Lingua::EN::Inflect::Number::to_S($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; + + 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); + + @part_parts = split /\s+/, $inflected; + } + + push @all_parts, join '', map ucfirst, @part_parts; + } + + return join $self->moniker_part_separator, @all_parts; } sub _table2moniker { @@ -2283,15 +2735,18 @@ sub _load_relationships { my @tables; foreach my $table (@$tables) { + my $local_moniker = $self->monikers->{$table->sql_name}; + my $tbl_fk_info = $self->_table_fk_info($table); + foreach my $fkdef (@$tbl_fk_info) { + $fkdef->{local_table} = $table; + $fkdef->{local_moniker} = $local_moniker; $fkdef->{remote_source} = - $self->monikers->{delete $fkdef->{remote_table}}; + $self->monikers->{$fkdef->{remote_table}->sql_name}; } my $tbl_uniq_info = $self->_table_uniq_info($table); - my $local_moniker = $self->monikers->{$table}; - push @tables, [ $local_moniker, $tbl_fk_info, $tbl_uniq_info ]; } @@ -2299,9 +2754,16 @@ sub _load_relationships { foreach my $src_class (sort keys %$rel_stmts) { # sort by rel name - my @src_stmts = map $_->[1], - sort { $a->[0] cmp $b->[0] } - map [ $_->{args}[0], $_ ], @{ $rel_stmts->{$src_class} }; + my @src_stmts = map $_->[2], + sort { + $a->[0] <=> $b->[0] + || + $a->[1] cmp $b->[1] + } map [ + ($_->{method} eq 'many_to_many' ? 1 : 0), + $_->{args}[0], + $_, + ], @{ $rel_stmts->{$src_class} }; foreach my $stmt (@src_stmts) { $self->_dbic_stmt($src_class,$stmt->{method}, @{$stmt->{args}}); @@ -2312,8 +2774,8 @@ sub _load_relationships { sub _load_roles { my ($self, $table) = @_; - my $table_moniker = $self->monikers->{$table}; - my $table_class = $self->classes->{$table}; + my $table_moniker = $self->monikers->{$table->sql_name}; + my $table_class = $self->classes->{$table->sql_name}; my @roles = @{ $self->result_roles || [] }; push @roles, @{ $self->result_roles_map->{$table_moniker} } @@ -2430,7 +2892,7 @@ sub _make_pod { } } $self->_pod_cut( $class ); - } elsif ( $method =~ /^(belongs_to|has_many|might_have)$/ ) { + } elsif ( $method =~ /^(?:belongs_to|has_many|might_have)\z/ ) { $self->_pod( $class, "=head1 RELATIONS" ) unless $self->{_relations_started} { $class } ; my ( $accessor, $rel_class ) = @_; $self->_pod( $class, "=head2 $accessor" ); @@ -2438,16 +2900,24 @@ sub _make_pod { $self->_pod( $class, "Related object: L<$rel_class>" ); $self->_pod_cut( $class ); $self->{_relations_started} { $class } = 1; + } elsif ( $method eq 'many_to_many' ) { + $self->_pod( $class, "=head1 RELATIONS" ) unless $self->{_relations_started} { $class } ; + my ( $accessor, $rel1, $rel2 ) = @_; + $self->_pod( $class, "=head2 $accessor" ); + $self->_pod( $class, 'Type: many_to_many' ); + $self->_pod( $class, "Composing rels: L -> $rel2" ); + $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"); } @@ -2460,7 +2930,7 @@ sub _make_pod { 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"); } @@ -2489,7 +2959,7 @@ sub _pod_class_list { sub _base_class_pod { my ($self, $base_class) = @_; - return unless $self->generate_pod; + return '' unless $self->generate_pod; return <<"EOF" =head1 BASE CLASS: L<$base_class> @@ -2515,7 +2985,7 @@ sub __table_comment { if (my $code = $self->can('_table_comment')) { return $self->_filter_comment($self->$code(@_)); } - + return ''; } @@ -2585,19 +3055,16 @@ sub _uc { return $self->preserve_case ? $name : uc($name); } -sub _unregister_source_for_table { +sub _remove_table { my ($self, $table) = @_; try { - local $@; my $schema = $self->schema; # in older DBIC it's a private method my $unregister = $schema->can('unregister_source') || $schema->can('_unregister_source'); - $schema->$unregister($self->_table2moniker($table)); - delete $self->monikers->{$table}; - delete $self->classes->{$table}; - delete $self->_upgrading_classes->{$table}; - delete $self->{_tables}{$table}; + $schema->$unregister(delete $self->monikers->{$table->sql_name}); + delete $self->_upgrading_classes->{delete $self->classes->{$table->sql_name}}; + delete $self->_tables->{$table->sql_name}; }; } @@ -2622,6 +3089,18 @@ 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. +=head1 NON-ENGLISH DATABASES + +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 loader options: + + naming => { monikers => 'v4' }, + inflect_singular => sub { "$_[0]_rel" }, + inflect_plural => sub { "$_[0]_rel" }, + =head1 COLUMN ACCESSOR COLLISIONS Occasionally you may have a column name that collides with a perl method, such @@ -2651,7 +3130,7 @@ You can also control the renaming with the L option. =head1 SEE ALSO -L +L, L =head1 AUTHOR