use base qw/Class::Accessor::Grouped Class::C3::Componentised/;
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 File::Slurp 'slurp';
-use DBIx::Class::Schema::Loader::Utils qw/split_name dumper_squashed eval_without_redefine_warnings/;
+use DBIx::Class::Schema::Loader::Utils qw/split_name dumper_squashed eval_package_without_redefine_warnings class_path slurp_file/;
use DBIx::Class::Schema::Loader::Optional::Dependencies ();
use Try::Tiny;
use DBIx::Class ();
+use Encode qw/encode decode/;
+use List::MoreUtils qw/all any firstidx uniq/;
+use File::Temp 'tempfile';
use namespace::clean;
-our $VERSION = '0.07002';
+our $VERSION = '0.07018';
__PACKAGE__->mk_group_ro_accessors('simple', qw/
schema
additional_base_classes
left_base_classes
components
- resultset_components
+ schema_components
skip_relationships
skip_load_external
moniker_map
+ col_accessor_map
custom_column_info
inflect_singular
inflect_plural
default_resultset_class
schema_base_class
result_base_class
+ result_roles
use_moose
+ only_autoclean
overwrite_modifications
relationship_attrs
- db_schema
_tables
classes
_upgrading_classes
datetime_locale
config_file
loader_class
- qualify_objects
+ table_comments_table
+ column_comments_table
+ class_to_table
+ moniker_to_table
+ uniq_to_primary
+ quiet
/);
pod_comment_mode
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
+ filter_generated_code
+ db_schema
+ qualify_objects
+ moniker_parts
/);
+my $CURRENT_V = 'v7';
+
+my @CLASS_ARGS = qw(
+ schema_components schema_base_class result_base_class
+ additional_base_classes left_base_classes additional_classes components
+ result_roles
+);
+
+my $CR = "\x0d";
+my $LF = "\x0a";
+my $CRLF = "\x0d\x0a";
+
=head1 NAME
DBIx::Class::Schema::Loader::Base - Base DBIx::Class::Schema::Loader Implementation.
=head1 SYNOPSIS
-See L<DBIx::Class::Schema::Loader>
+See L<DBIx::Class::Schema::Loader>.
=head1 DESCRIPTION
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</relationships>, L</monikers> and L</column_accessors> to the specified
+value.
+
=item relationships
How to name relationship accessors.
How to name column accessors in Result classes.
+=item force_ascii
+
+For L</v8> mode and later, uses L<String::ToIdentifier::EN> instead of
+L<String::ToIdentifier::EM::Unicode> to force monikers and other identifiers to
+ASCII.
+
=back
The values can be:
=item v7
This mode is identical to C<v6> 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</preserve_case>.
+CamelCase column names in case-preserving mode will also be handled better
+for relationship name inflection (but best in v8.) See L</preserve_case>.
In this mode, CamelCase L</column_accessors> are normalized based on case
transition instead of just being lowercased, so C<FooId> becomes C<foo_id>.
-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</v7>, to get L</v8> mode, you have to specify it in
+L</naming> explicitly until C<0.08> comes out.
+
+L</monikers> and L</column_accessors> are created using
+L<String::ToIdentifier::EN::Unicode> or L<String::ToIdentifier::EN> if
+L</force_ascii> 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<VLANValidID> 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<Id>, C<_?ref>, C<_?cd>,
+C<_?code> and C<_?num>, case insensitively.
+
+=item preserve
+
+For L</monikers>, this option does not inflect the table names but makes
+monikers based on the actual name. For L</column_accessors> 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</monikers>, singularizes the names using the most current inflector. This
+is the same as setting the option to L</current>.
+
+=item plural
+
+For L</monikers>, pluralizes the names, using the most current inflector.
=back
__PACKAGE__->naming('v7');
+=head2 quiet
+
+If true, will not print the usual C<Dumping manual schema ... Schema dump
+completed.> messages. Does not affect warnings (except for warnings related to
+L</really_erase_my_files>.)
+
=head2 generate_pod
By default POD will be generated for columns and relationships, using database
metadata for the text if available and supported.
-Reading database metadata (e.g. C<COMMENT ON TABLE some_table ...>) is only
-supported for Postgres right now.
+Comment metadata can be stored in two ways.
+
+The first is that you can create two tables named C<table_comments> and
+C<column_comments> respectively. These tables must exist in the same database
+and schema as the tables they describe. They both need to have columns named
+C<table_name> and C<comment_text>. The second one needs to have a column named
+C<column_name>. 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</table_comments_table> and L</column_comments_table>.)
+
+As a fallback you can use built-in commenting mechanisms. Currently this is
+only supported for PostgreSQL, Oracle and MySQL. To create comments in
+PostgreSQL you add statements of the form C<COMMENT ON TABLE some_table IS
+'...'>, the same syntax is used in Oracle. To create comments in MySQL you add
+C<COMMENT '...'> to the end of the column or table definition. Note that MySQL
+restricts the length of comments, and also does not handle complex Unicode
+characters properly.
Set this to C<0> to turn off all POD generation.
The default is C<60>
+=head2 table_comments_table
+
+The table to look for comments about tables in. By default C<table_comments>.
+See L</generate_pod> 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<column_comments>.
+See L</generate_pod> 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
=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</moniker_parts>.
+
+=head2 moniker_parts
+
+The database table names are represented by the
+L<DBIx::Class::Schema::Loader::Table> class in the loader, the
+L<DBIx::Class::Schema::Loader::Table::Sybase> class for Sybase ASE and
+L<DBIx::Class::Schema::Loader::Table::Informix> for Informix.
+
+Monikers are created normally based on just the
+L<name|DBIx::Class::Schema::Loader::DBObject/name> property, corresponding to
+the table name, but can consist of other parts of the fully qualified name of
+the table.
+
+The L</moniker_parts> 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 C<'name'> entry B<must> be present.
+
+Below is a table of supported databases and possible L</moniker_parts>.
+
+=over 4
+
+=item * DB2, Firebird, mysql, Oracle, Pg, SQLAnywhere, SQLite, MS Access
+
+C<schema>, C<name>
+
+=item * Informix, MSSQL, Sybase ASE
+
+C<database>, C<schema>, C<name>
+
+=back
=head2 constraint
=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<table object|DBIx::Class::Schema::Loader::Table> 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
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 => 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<table object|DBIx::Class::Schema::Loader::Table> stringifies to the
+unqualified table name.
+
+=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<bar> will now be named C<baz>
+except that in the table whose moniker is C<Foo> it will be named C<blat>.
+
+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<has_many>,
+ 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</moniker_map> above (can be hash/code-ref, falls back to default
if hash key does not exist or coderef returns false), but acts as a map
for pluralizing relationship names. The default behavior is to utilize
-L<Lingua::EN::Inflect::Number/to_PL>.
+L<Lingua::EN::Inflect::Phrase/to_PL>.
=head2 inflect_singular
As L</inflect_plural> above, but for singularizing relationship names.
-Default behavior is to utilize L<Lingua::EN::Inflect::Number/to_S>.
+Default behavior is to utilize L<Lingua::EN::Inflect::Phrase/to_S>.
=head2 schema_base_class
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
=head2 components
-List of additional components to be loaded into all of your table
+List of additional components to be loaded into all of your Result
classes. A good example would be
L<InflateColumn::DateTime|DBIx::Class::InflateColumn::DateTime>
-=head2 resultset_components
+=head2 result_components_map
+
+A hashref of moniker keys and component values. Unlike L</components>, which
+loads the given components into every Result class, this option allows you to
+load certain components for specified Result classes. For example:
-List of additional ResultSet components to be loaded into your table
-classes. A good example would be C<AlwaysRS>. Component
-C<ResultSetManager> will be automatically added to the above
-C<components> list if this option is set.
+ result_components_map => {
+ StationVisited => '+YourApp::Schema::Component::StationVisited',
+ RouteChange => [
+ '+YourApp::Schema::Component::RouteChange',
+ 'InflateColumn::DateTime',
+ ],
+ }
+
+You may use this in conjunction with L</components>.
+
+=head2 result_roles
+
+List of L<Moose> roles to be applied to all of your Result classes.
+
+=head2 result_roles_map
+
+A hashref of moniker keys and role values. Unlike L</result_roles>, 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</result_roles>.
=head2 use_namespaces
=head2 dump_directory
-This option is designed to be a tool to help you transition from this
-loader to a manually-defined schema when you decide it's time to do so.
-
The value of this option is a perl libdir pathname. Within
that directory this module will create a baseline manual
-L<DBIx::Class::Schema> module set, based on what it creates at runtime
-in memory.
+L<DBIx::Class::Schema> module set, based on what it creates at runtime.
The created schema class will have the same classname as the one on
which you are setting this option (and the ResultSource classes will be
The default behavior is instead to only replace the top portion of the
file, up to and including the final stanza which contains
-C<# DO NOT MODIFY THIS OR ANYTHING ABOVE!>
+C<# DO NOT MODIFY THE FIRST PART OF THIS FILE>
leaving any customizations you placed after that as they were.
When C<really_erase_my_files> is not set, if the output file already exists,
Must be a coderef that returns a hashref with the extra attributes.
-Receives the table name, column name and column_info.
+Receives the L<table object|DBIx::Class::Schema::Loader::Table> (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 };
Sets the locale attribute for L<DBIx::Class::InflateColumn::DateTime> 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<DON'T> 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
=head2 preserve_case
-Usually column names are lowercased, to make them easier to work with in
-L<DBIx::Class>. 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<NOTE:> L</naming> = C<v8> is highly recommended with this option as the
+semantics of this mode are much improved for CamelCase database names.
+
+L</naming> = C<v7> or greater is required with this option.
=head2 qualify_objects
Set to true to prepend the L</db_schema> 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<Moose>, L<MooseX::NonMoose> and
-L<namespace::autoclean>. The default content after the md5 sum also makes the
-classes immutable.
+L<MooseX::MarkAsMethods> (or L<namespace::autoclean>, 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<MooseX::MarkAsMethods> to remove imported functions from
+your generated classes. It uses L<namespace::autoclean> to do this, after
+telling your object's metaclass that any operator L<overload>s 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<namespace::autoclean> itself.
+
+If none of the above made any sense, or you don't have some pressing need to
+only use L<namespace::autoclean>, leaving this set to the default is
+recommended.
+
+=head2 col_collision_map
+
+This option controls how accessors for column names which collide with perl
+methods are named. See L</COLUMN ACCESSOR COLLISIONS> for more information.
+
+This option takes either a single L<sprintf|perlfunc/sprintf> format or a hashref of
+strings which are compiled to regular expressions that map to
+L<sprintf|perlfunc/sprintf> formats.
+
+Examples:
+
+ col_collision_map => 'column_%s'
+
+ col_collision_map => { '(.*)' => 'column_%s' }
+
+ col_collision_map => { '(foo).*(bar)' => 'column_%s_%s' }
+
+=head2 rel_collision_map
+
+Works just like L</col_collision_map>, but for relationship names/accessors
+rather than column names/accessors.
+
+The default is to just append C<_rel> to the relationship name, see
+L</RELATIONSHIP NAME COLLISIONS>.
+
+=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.
+
+=head2 filter_generated_code
+
+An optional hook that lets you filter the generated text for various classes
+through a function that change it in any way that you want. The function will
+receive the type of file, C<schema> or C<result>, class and code; and returns
+the new code to use instead. For instance you could add custom comments, or do
+anything else that you want.
+
+The option can also be set to a string, which is then used as a filter program,
+e.g. C<perltidy>.
+
+If this exists but fails to return text matching C</\bpackage\b/>, no file will
+be generated.
+
+ filter_generated_code => sub {
+ my ($type, $class, $text) = @_;
+ ...
+ return $new_code;
+ }
+
=head1 METHODS
None of these methods are intended for direct invocation by regular
=cut
-my $CURRENT_V = 'v7';
-
-my @CLASS_ARGS = qw(
- schema_base_class result_base_class additional_base_classes
- left_base_classes additional_classes components resultset_components
-);
-
# ensure that a peice of object data is a valid arrayref, creating
# an empty one or encapsulating whatever's there.
sub _ensure_arrayref {
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
}
}
- $self->_ensure_arrayref(qw/additional_classes
+ 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/schema_components
+ additional_classes
additional_base_classes
left_base_classes
components
- resultset_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",
}
}
- push(@{$self->{components}}, 'ResultSetManager')
- if @{$self->{resultset_components}};
-
+ $self->{_tables} = {};
$self->{monikers} = {};
- $self->{classes} = {};
+ $self->{moniker_to_table} = {};
+ $self->{class_to_table} = {};
+ $self->{classes} = {};
$self->{_upgrading_classes} = {};
$self->{schema_class} ||= ( ref $self->{schema} || $self->{schema} );
$self->{schema} ||= $self->{schema_class};
+ $self->{table_comments_table} ||= 'table_comments';
+ $self->{column_comments_table} ||= 'column_comments';
croak "dump_overwrite is deprecated. Please read the"
. " DBIx::Class::Schema::Loader::Base documentation"
$self->{dump_directory} ||= $self->{temp_directory};
+ $self->real_dump_directory($self->{dump_directory});
+
$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} = {
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} ||= {};
$self->pod_comment_mode('auto') unless defined $self->pod_comment_mode;
$self->pod_comment_spillover_length(60) unless defined $self->pod_comment_spillover_length;
- $self;
+ if (my $col_collision_map = $self->col_collision_map) {
+ if (my $reftype = ref $col_collision_map) {
+ if ($reftype ne 'HASH') {
+ croak "Invalid type $reftype for option 'col_collision_map'";
+ }
+ }
+ else {
+ $self->col_collision_map({ '(.*)' => $col_collision_map });
+ }
+ }
+
+ 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(my $filter = $self->filter_generated_code)) {
+ my $reftype = ref $filter;
+ if ($reftype && $reftype ne 'CODE') {
+ croak "Invalid type $reftype for option 'filter_generated_code, must be a scalar or a CODE reference";
+ }
+ }
+
+ 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 ];
+ }
+ }
+
+ 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'";
+ }
+ }
+
+ return $self;
}
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 <<EOF unless $ENV{SCHEMA_LOADER_BACKCOMPAT};
Dynamic schema detected, will run in 0.04006 mode.
Set the 'naming' attribute or the SCHEMA_LOADER_BACKCOMPAT environment variable
to disable this warning.
-Also consider setting 'use_namespaces => 1' if/when upgrading.
-
See perldoc DBIx::Class::Schema::Loader::Manual::UpgradingFromV4 for more
details.
EOF
$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';
}
# 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) =
}
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};
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) = @_;
my $fullpath = File::Spec->catfile($prefix, $file);
return $fullpath if -f $fullpath
# abs_path throws on Windows for nonexistant files
- and eval { Cwd::abs_path($fullpath) } ne
- (eval { Cwd::abs_path(File::Spec->catfile($self->dump_directory, $file)) } || '');
+ and (try { Cwd::abs_path($fullpath) }) ne
+ ((try { Cwd::abs_path(File::Spec->catfile($self->dump_directory, $file)) }) || '');
}
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 {
warn qq/# Loaded external class definition for '$class'\n/
if $self->debug;
- open(my $fh, '<', $real_inc_path)
- or croak "Failed to open '$real_inc_path' for reading: $!";
- my $code = do { local $/; <$fh> };
- close($fh)
- or croak "Failed to close $real_inc_path: $!";
- $code = $self->_rewrite_old_classnames($code);
+ my $code = $self->_rewrite_old_classnames(slurp_file $real_inc_path);
if ($self->dynamic) { # load the class too
- eval_without_redefine_warnings($code);
+ eval_package_without_redefine_warnings($class, $code);
}
$self->_ext_stmt($class,
}
if ($old_real_inc_path) {
- my $code = slurp $old_real_inc_path;
+ my $code = slurp_file $old_real_inc_path;
$self->_ext_stmt($class, <<"EOF");
* 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;
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);
}
}
- delete $self->{_dump_storage};
- delete $self->{_relations_started};
+ delete @$self{qw/_dump_storage _relations_started _uniqs_started/};
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 {
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;
- eval "require $relbuilder_class"; die $@ if $@;
- $relbuilder_class->new( $self );
-
+ $self->ensure_class_loaded($relbuilder_class);
+ $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 = 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;
+
+ 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
- $self->{quiet} = 1;
+ local $self->{quiet} = 1;
local $self->{dump_directory} = $self->{temp_directory};
$self->_reload_classes(\@tables);
- $self->_load_relationships($_) for @tables;
- $self->{quiet} = 0;
+ $self->_load_relationships(\@tables);
# Remove that temp dir from INC so it doesn't get reloaded
@INC = grep $_ ne $self->dump_directory, @INC;
}
- $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.
- $self->_reload_classes(\@tables, 0);
+ $self->_reload_classes(\@tables, { unload => 0 });
# Drop temporary cache
delete $self->{_cache};
}
sub _reload_classes {
- my ($self, $tables, $unload) = @_;
+ my ($self, $tables, $opts) = @_;
my @tables = @$tables;
+
+ my $unload = $opts->{unload};
$unload = 1 unless defined $unload;
# 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;
$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';
sub _moose_metaclass {
return undef unless $INC{'Class/MOP.pm'}; # if CMOP is not loaded the class could not have loaded in the 1st place
- my $mc = Class::MOP::class_of($_[1])
+ my $class = $_[1];
+
+ my $mc = try { Class::MOP::class_of($class) }
or return undef;
return $mc->isa('Moose::Meta::Class') ? $mc : undef;
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
- eval {
- eval_without_redefine_warnings ("require $class");
+ try {
+ eval_package_without_redefine_warnings ($class, "require $class");
+ }
+ catch {
+ my $source = slurp_file $self->_get_dump_filename($class);
+ die "Failed to reload class $class: $_.\n\nCLASS SOURCE:\n\n$source";
};
- die "Failed to reload class $class: $@" if $@;
}
sub _get_dump_filename {
return $self->dump_directory . q{/} . $class . q{.pm};
}
+=head2 get_dump_filename
+
+Arguments: class
+
+Returns the full path to the file for a class that the class has been or will
+be dumped to. This is a file in a temp dir for a dynamic schema.
+
+=cut
+
+sub get_dump_filename {
+ my ($self, $class) = (@_);
+
+ local $self->{dump_directory} = $self->real_dump_directory;
+
+ return $self->_get_dump_filename($class);
+}
+
sub _ensure_dump_subdirs {
my ($self, $class) = (@_);
my $target_dir = $self->dump_directory;
warn "Dumping manual schema for $schema_class to directory $target_dir ...\n"
- unless $self->{dynamic} or $self->{quiet};
+ 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|
- . qq|use strict;\nuse warnings;\n\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 MooseX::NonMoose;\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 base '$schema_base_class';\n\n|;
+ $schema_text .= qq|use strict;\nuse warnings;\n\nuse base '$schema_base_class';\n\n|;
+ }
+
+ my @schema_components = @{ $self->schema_components || [] };
+
+ if (@schema_components) {
+ my $schema_components = dump @schema_components;
+ $schema_components = "($schema_components)" if @schema_components == 1;
+
+ $schema_text .= "__PACKAGE__->load_components${schema_components};\n\n";
}
if ($self->use_namespaces) {
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;
foreach my $src_class (@classes) {
my $src_text =
- qq|package $src_class;\n\n|
+ 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|
- . 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;|;
+ $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 }) {
- $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);
}
}
}
- warn "Schema dump completed.\n" unless $self->{dynamic} or $self->{quiet};
-
+ warn "Schema dump completed.\n" unless $self->dynamic or $self->quiet;
}
sub _sig_comment {
if (-f $filename && $self->really_erase_my_files) {
warn "Deleting existing file '$filename' due to "
- . "'really_erase_my_files' setting\n" unless $self->{quiet};
+ . "'really_erase_my_files' setting\n" unless $self->quiet;
unlink($filename);
}
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;
}
}
- $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.
};
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) {
$text .= qq|$_\n|
for @{$self->{_dump_storage}->{$class} || []};
- # Check and see if the dump is infact differnt
+ if ($self->filter_generated_code) {
+ my $filter = $self->filter_generated_code;
+
+ if (ref $filter eq 'CODE') {
+ $text = $filter->(
+ ($is_schema ? 'schema' : 'result'),
+ $class,
+ $text
+ );
+ }
+ else {
+ my ($fh, $temp_file) = tempfile();
+
+ binmode $fh, ':encoding(UTF-8)';
+ print $fh $text;
+ close $fh;
+
+ 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;
+
+ 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";
+ }
+ }
+ if (not $text or not $text =~ /\bpackage\b/) {
+ warn("$class skipped due to filter") if $self->debug;
+ return;
+ }
+ }
+
+ # Check and see if the dump is in fact different
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;
}
}
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|
}
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;
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 =
- qr{^(# DO NOT MODIFY THIS OR ANYTHING ABOVE! md5sum:)([A-Za-z0-9/+]{22})\n};
+ qr{^(# DO NOT MODIFY THIS OR ANYTHING ABOVE! md5sum:)([A-Za-z0-9/+]{22})\r?\n};
my ($md5, $ts, $ver, $gen);
while(<$fh>) {
$md5 = $2;
# Pull out the version and timestamp from the line above
- ($ver, $ts) = $gen =~ m/^# Created by DBIx::Class::Schema::Loader v(.*?) @ (.*?)\Z/m;
+ ($ver, $ts) = $gen =~ m/^# Created by DBIx::Class::Schema::Loader v(.*?) @ (.*?)\r?\Z/m;
$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;
}
my $custom = do { local $/; <$fh> }
if $md5;
- close ($fh);
+ $custom ||= '';
+ $custom =~ s/$CRLF|$LF/\n/g;
+
+ close $fh;
return ($gen, $md5, $ver, $ts, $custom);
}
$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)
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';
);
}
- 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;
}
-# 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->sql_name} = $table_class;
+ $self->moniker_to_table->{$table_moniker} = $table;
+ $self->class_to_table->{$table_class} = $table;
- $self->classes->{$table} = $table_class;
- $self->monikers->{$table} = $table_moniker;
+ $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->_dbic_stmt($table_class, 'load_resultset_components', @{$self->resultset_components})
- if @{$self->resultset_components};
+ $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, $col_info) = @_;
+sub _is_result_class_method {
+ my ($self, $name, $table) = @_;
+
+ my $table_moniker = $table ? $self->monikers->{$table->sql_name} : '';
+
+ $self->_result_class_methods({})
+ if not defined $self->_result_class_methods;
+
+ if (not exists $self->_result_class_methods->{$table_moniker}) {
+ my (@methods, %methods);
+ my $base = $self->result_base_class || 'DBIx::Class::Core';
- my $base = $self->result_base_class || 'DBIx::Class::Core';
- my @components = map "DBIx::Class::$_", @{ $self->components || [] };
+ my @components = @{ $self->components || [] };
+
+ 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 @methods;
+ my @roles = @{ $self->result_roles || [] };
- for my $class ($base, @components, $self->use_moose ? 'Moose::Object' : ()) {
- eval "require ${class};";
- die $@ if $@;
+ push @roles, @{ $self->result_roles_map->{$table_moniker} }
+ if exists $self->result_roles_map->{$table_moniker};
- push @methods, @{ Class::Inspector->methods($class) || [] };
+ 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}) {
- $info->{accessor} = undef;
+ if ($self->_is_result_class_method($accessor, $table)) {
+ my $mapped = 0;
+
+ if (my $map = $self->col_collision_map) {
+ for my $re (keys %$map) {
+ if (my @matches = $col =~ /$re/) {
+ $info->{accessor} = sprintf $map->{$re}, @matches;
+ $mapped = 1;
+ }
+ }
+ }
+
+ if (not $mapped) {
+ warn <<"EOF";
+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;
+ }
}
}
}
+# 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 $preserve = ($self->naming->{column_accessors}||'') eq 'preserve';
+
+ my $v = $self->_get_naming_v('column_accessors');
+
+ 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;
+ }
+
+ return join '_', map lc, split_name $column_name, $v;
+}
+
sub _make_column_accessor_name {
- my ($self, $column_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 join '_', map lc, split_name $column_name;
+ return $accessor;
}
# Set up metadata (cols, pks, etc)
my $schema = $self->schema;
my $schema_class = $self->schema_class;
- my $table_class = $self->classes->{$table};
- my $table_moniker = $self->monikers->{$table};
+ my $table_class = $self->classes->{$table->sql_name};
+ my $table_moniker = $self->monikers->{$table->sql_name};
- my $table_name = $table;
- my $name_sep = $self->schema->storage->sql_maker->name_sep;
+ $self->_dbic_stmt($table_class, 'table', $table->dbic_name);
- if ($name_sep && $table_name =~ /\Q$name_sep\E/) {
- $table_name = \ $self->_quote_table_name($table_name);
- }
-
- my $full_table_name = ($self->qualify_objects ? ($self->db_schema . '.') : '') . (ref $table_name ? $$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;
-
- $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,
+ full_table_name => $table->dbic_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($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);
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;
}
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
+ # Sort unique constraints by constraint name for repeatable results (rels
+ # are sorted as well elsewhere.)
+ @uniqs = sort { $a->[0] cmp $b->[0] } @uniqs;
- 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 {
sub tables {
my $self = shift;
- return keys %{$self->_tables};
+ return values %{$self->_tables};
}
-# Make a moniker from a table
-sub _default_table2moniker {
- no warnings 'uninitialized';
- my ($self, $table) = @_;
+sub _get_naming_v {
+ my ($self, $naming_key) = @_;
+
+ my $v;
- if ($self->naming->{monikers} eq 'v4') {
- return join '', map ucfirst, split /[\W_]+/, lc $table;
+ if (($self->naming->{$naming_key}||'') =~ /^v(\d+)\z/) {
+ $v = $1;
}
- elsif ($self->naming->{monikers} eq 'v5') {
- return join '', map ucfirst, split /[\W_]+/,
- Lingua::EN::Inflect::Number::to_S(lc $table);
+ else {
+ ($v) = $CURRENT_V =~ /^v(\d+)\z/;
}
- elsif ($self->naming->{monikers} eq 'v6') {
- (my $as_phrase = lc $table) =~ s/_+/ /g;
- my $inflected = Lingua::EN::Inflect::Phrase::to_S($as_phrase);
- return join '', map ucfirst, split /\W+/, $inflected;
- }
+ return $v;
+}
+
+sub _to_identifier {
+ my ($self, $naming_key, $name, $sep_char, $force) = @_;
- my @words = map lc, split_name $table;
- my $as_phrase = join ' ', @words;
+ my $v = $self->_get_naming_v($naming_key);
- my $inflected = Lingua::EN::Inflect::Phrase::to_S($as_phrase);
+ my $to_identifier = $self->naming->{force_ascii} ?
+ \&String::ToIdentifier::EN::to_identifier
+ : \&String::ToIdentifier::EN::Unicode::to_identifier;
- return join '', map ucfirst, split /\W+/, $inflected;
+ return $v >= 8 || $force ? $to_identifier->($name, $sep_char) : $name;
}
-sub _table2moniker {
- my ( $self, $table ) = @_;
+# Make a moniker from a table
+sub _default_table2moniker {
+ my ($self, $table) = @_;
- my $moniker;
+ my $v = $self->_get_naming_v('monikers');
- if( ref $self->moniker_map eq 'HASH' ) {
- $moniker = $self->moniker_map->{$table};
- }
- elsif( ref $self->moniker_map eq 'CODE' ) {
- $moniker = $self->moniker_map->($table);
+ my @name_parts = map $table->$_, @{ $self->moniker_parts };
+
+ my $name_idx = firstidx { $_ eq 'name' } @{ $self->moniker_parts };
+
+ my @all_parts;
+
+ foreach my $i (0 .. $#name_parts) {
+ my $part = $name_parts[$i];
+
+ 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, map ucfirst, @part_parts;
}
- $moniker ||= $self->_default_table2moniker($table);
+ return join '', @all_parts;
+}
- return $moniker;
+sub _table2moniker {
+ my ( $self, $table ) = @_;
+
+ $self->_run_user_map(
+ $self->moniker_map,
+ sub { $self->_default_table2moniker( shift ) },
+ $table
+ );
}
sub _load_relationships {
- my ($self, $table) = @_;
+ my ($self, $tables) = @_;
+
+ 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->{$fkdef->{remote_table}->sql_name};
+ }
+ my $tbl_uniq_info = $self->_table_uniq_info($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};
- foreach my $stmt (@$src_stmts) {
- $self->_dbic_stmt($src_class,$stmt->{method},@{$stmt->{args}});
+ # sort by rel name
+ 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}});
}
}
}
+sub _load_roles {
+ my ($self, $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} }
+ if exists $self->result_roles_map->{$table_moniker};
+
+ if (@roles) {
+ $self->_pod_class_list($table_class, 'L<Moose> ROLES APPLIED', @roles);
+
+ $self->_with($table_class, @roles);
+ }
+}
+
# Overload these in driver class:
# Returns an arrayref of column names
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 {
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 = @_;
" $_: $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 );
}
}
$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" );
$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</$rel1> -> $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</$col>");
+ }
+
+ $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</$col>");
+ }
+
+ $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 {
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 ) = @_;
return $self->preserve_case ? $name : uc($name);
}
-sub _unregister_source_for_table {
+sub _remove_table {
my ($self, $table) = @_;
- eval {
- local $@;
+ try {
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};
};
}
contain multiple entries per table for the original and normalized table
names, as above in L</monikers>.
+=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
+as C<can>. In such cases, the default action is to set the C<accessor> of the
+column spec to C<undef>.
+
+You can then name the accessor yourself by placing code such as the following
+below the md5:
+
+ __PACKAGE__->add_column('+can' => { accessor => 'my_can' });
+
+Another option is to use the L</col_collision_map> 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<belongs_to>.
+
+This is a problem because relationship names are also relationship accessor
+methods in L<DBIx::Class>.
+
+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</rel_collision_map> option.
+
=head1 SEE ALSO
-L<DBIx::Class::Schema::Loader>
+L<DBIx::Class::Schema::Loader>, L<dbicdump>
=head1 AUTHOR
projects / dbsrgits/DBIx-Class-Schema-Loader.git / blobdiff