use Class::Inspector ();
use Scalar::Util 'looks_like_number';
use File::Slurp 'slurp';
-use DBIx::Class::Schema::Loader::Utils qw/split_name dumper_squashed/;
+use DBIx::Class::Schema::Loader::Utils qw/split_name dumper_squashed eval_package_without_redefine_warnings class_path/;
use DBIx::Class::Schema::Loader::Optional::Dependencies ();
use Try::Tiny;
use DBIx::Class ();
+use Encode qw/decode encode/;
use namespace::clean;
-our $VERSION = '0.07001';
+our $VERSION = '0.07010';
__PACKAGE__->mk_group_ro_accessors('simple', qw/
schema
additional_base_classes
left_base_classes
components
- resultset_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
overwrite_modifications
pod_comment_mode
pod_comment_spillover_length
preserve_case
+ col_collision_map
+ rel_collision_map
+ real_dump_directory
+ result_components_map
+ result_roles_map
+ datetime_undef_if_invalid
+ _result_class_methods
+ naming_set
+ tables
/);
=head1 NAME
stations_visited | StationVisited
routeChange | RouteChange
+=head2 col_accessor_map
+
+Same as moniker_map, but for column accessor names. If a coderef is
+passed, the code is called with arguments of
+
+ the name of the column in the underlying database,
+ default accessor name that DBICSL would ordinarily give this column,
+ {
+ table_class => name of the DBIC class we are building,
+ table_moniker => calculated moniker for this table (after moniker_map if present),
+ table_name => name of the database table,
+ full_table_name => schema-qualified name of the database table (RDBMS specific),
+ schema_class => name of the schema class we are building,
+ column_info => hashref of column info (data_type, is_nullable, etc),
+ }
+
=head2 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
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:
+
+ 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 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.
+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,
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
It is safe to upgrade your existing Schema to this option.
+=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>.
+
=head1 METHODS
None of these methods are intended for direct invocation by regular
my @CLASS_ARGS = qw(
schema_base_class result_base_class additional_base_classes
- left_base_classes additional_classes components resultset_components
+ left_base_classes additional_classes components result_roles
);
# ensure that a peice of object data is a valid arrayref, creating
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->result_components_map($self->{result_component_map})
+ if defined $self->{result_component_map};
+
+ $self->result_roles_map($self->{result_role_map})
+ if defined $self->{result_role_map};
+
+ croak "the result_roles and result_roles_map options may only be used in conjunction with use_moose=1"
+ if ((not defined $self->use_moose) || (not $self->use_moose))
+ && ((defined $self->result_roles) || (defined $self->result_roles_map));
+
$self->_ensure_arrayref(qw/additional_classes
additional_base_classes
left_base_classes
components
- 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.\nYou are missing: %s.\n",
- "Moose, MooseX::NonMoose and namespace::autoclean",
+ die sprintf "You must install the following CPAN modules to enable the use_moose option: %s.\n",
DBIx::Class::Schema::Loader::Optional::Dependencies->req_missing_for('use_moose');
}
}
- push(@{$self->{components}}, 'ResultSetManager')
- if @{$self->{resultset_components}};
-
$self->{monikers} = {};
- $self->{classes} = {};
+ $self->{tables} = {};
+ $self->{classes} = {};
$self->{_upgrading_classes} = {};
$self->{schema_class} ||= ( ref $self->{schema} || $self->{schema} );
$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} = {
$self->pod_comment_mode('auto') unless defined $self->pod_comment_mode;
$self->pod_comment_spillover_length(60) unless defined $self->pod_comment_spillover_length;
+ 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 });
+ }
+ }
+
$self;
}
# 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';
# determine if the existing schema was dumped with use_moose => 1
if (! defined $self->use_moose) {
- $self->use_moose(1) if $old_gen =~ /^ (?!\s*\#) use \s+ Moose/xm;
+ $self->{use_moose} = 1 if $old_gen =~ /^ (?!\s*\#) use \s+ Moose/xm;
}
my $load_classes = ($old_gen =~ /^__PACKAGE__->load_classes;/m) ? 1 : 0;
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(decode 'UTF-8', scalar slurp $real_inc_path);
if ($self->dynamic) { # load the class too
- # kill redefined warnings
- my $warn_handler = $SIG{__WARN__} || sub { warn @_ };
- local $SIG{__WARN__} = sub {
- $warn_handler->(@_)
- unless $_[0] =~ /^Subroutine \S+ redefined/;
- };
- eval $code;
- die $@ if $@;
+ 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 = decode 'UTF-8', scalar slurp $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
- # kill redefined warnings
- my $warn_handler = $SIG{__WARN__} || sub { warn @_ };
- local $SIG{__WARN__} = sub {
- $warn_handler->(@_)
- unless $_[0] =~ /^Subroutine \S+ redefined/;
- };
- eval $code;
- die $@ if $@;
+ eval_package_without_redefine_warnings($class, $code);
}
chomp $code;
->{ $self->naming->{relationships}};
my $relbuilder_class = 'DBIx::Class::Schema::Loader::RelBuilder'.$relbuilder_suff;
- eval "require $relbuilder_class"; die $@ if $@;
+ $self->ensure_class_loaded($relbuilder_class);
$relbuilder_class->new( $self );
};
$self->{quiet} = 1;
local $self->{dump_directory} = $self->{temp_directory};
$self->_reload_classes(\@tables);
- $self->_load_relationships($_) for @tables;
+ $self->_load_relationships(\@tables);
$self->{quiet} = 0;
# Remove that temp dir from INC so it doesn't get reloaded
@INC = grep $_ ne $self->dump_directory, @INC;
}
+ $self->_load_roles($_) for @tables;
+
$self->_load_external($_)
for map { $self->classes->{$_} } @tables;
# 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
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
- my $warn_handler = $SIG{__WARN__} || sub { warn @_ };
- local $SIG{__WARN__} = sub {
- $warn_handler->(@_)
- unless $_[0] =~ /^Subroutine \S+ redefined/;
+ try {
+ eval_package_without_redefine_warnings ($class, "require $class");
+ }
+ catch {
+ my $source = decode 'UTF-8', scalar slurp $self->_get_dump_filename($class);
+ die "Failed to reload class $class: $_.\n\nCLASS SOURCE:\n\n$source";
};
- eval "require $class;";
- 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 $schema_text =
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|;
+
if ($self->use_moose) {
- $schema_text.= qq|use Moose;\nuse MooseX::NonMoose;\nuse namespace::autoclean;\nextends '$schema_base_class';\n\n|;
+ $schema_text.= qq|use Moose;\nuse namespace::autoclean;\nextends '$schema_base_class';\n\n|;
}
else {
- $schema_text .= qq|use base '$schema_base_class';\n\n|;
+ $schema_text .= qq|use strict;\nuse warnings;\n\nuse base '$schema_base_class';\n\n|;
}
if ($self->use_namespaces) {
else {
$src_text .= qq|use base '$result_base_class';\n\n|;
}
+
+ $self->_base_class_pod($src_class, $result_base_class)
+ unless $result_base_class eq 'DBIx::Class::Core';
+
$self->_write_classfile($src_class, $src_text);
}
}
}
- $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) {
+ croak 'It is not possible to "downgrade" a schema that was loaded with use_moose => 1 to use_moose => 0, due to differing custom content'
+ if $old_gen =~ /use \s+ MooseX?\b/x;
+ }
$custom_content = $self->_rewrite_old_classnames($custom_content);
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| content, and it will be preserved on regeneration|;
+ . 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 =
$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;
}
$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;
unless $table_class eq $old_class;
}
-# this was a bad idea, should be ok now without it
-# my $table_normalized = lc $table;
-# $self->classes->{$table_normalized} = $table_class;
-# $self->monikers->{$table_normalized} = $table_moniker;
-
- $self->classes->{$table} = $table_class;
+ $self->classes->{$table} = $table_class;
$self->monikers->{$table} = $table_moniker;
+ $self->tables->{$table_moniker} = $table;
+
+ $self->_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_name) = @_;
+
+ my $table_moniker = $table_name ? $self->monikers->{$table_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) = @_;
+
+ my $table_name = ref $table ? $$table : $table;
while (my ($col, $info) = each %$col_info) {
my $accessor = $info->{accessor} || $col;
next if $accessor eq 'id'; # special case (very common column)
- if (exists $methods{$accessor}) {
- $info->{accessor} = undef;
+ if ($self->_is_result_class_method($accessor, $table_name)) {
+ 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_name' collides with an inherited method.
+See "COLUMN ACCESSOR COLLISIONS" in perldoc DBIx::Class::Schema::Loader::Base .
+EOF
+ $info->{accessor} = undef;
+ }
}
}
}
-sub _make_column_accessor_name {
- my ($self, $column_name) = @_;
+# use the same logic to run moniker_map, col_accessor_map, and
+# relationship_name_map
+sub _run_user_map {
+ my ( $self, $map, $default_code, $ident, @extra ) = @_;
+
+ my $default_ident = $default_code->( $ident, @extra );
+ my $new_ident;
+ if( $map && ref $map eq 'HASH' ) {
+ $new_ident = $map->{ $ident };
+ }
+ elsif( $map && ref $map eq 'CODE' ) {
+ $new_ident = $map->( $ident, $default_ident, @extra );
+ }
+
+ $new_ident ||= $default_ident;
+
+ return $new_ident;
+}
+
+sub _default_column_accessor_name {
+ my ( $self, $column_name ) = @_;
+
+ my $accessor_name = $column_name;
+ $accessor_name =~ s/\W+/_/g;
+
+ if ((($self->naming->{column_accessors}||'') =~ /(\d+)/ && $1 < 7) || (not $self->preserve_case)) {
+ # older naming just lc'd the col accessor and that's all.
+ return lc $accessor_name;
+ }
return join '_', map lc, split_name $column_name;
+
+}
+
+sub _make_column_accessor_name {
+ my ($self, $column_name, $column_context_info ) = @_;
+
+ my $accessor = $self->_run_user_map(
+ $self->col_accessor_map,
+ sub { $self->_default_column_accessor_name( shift ) },
+ $column_name,
+ $column_context_info,
+ );
+
+ return $accessor;
}
# Set up metadata (cols, pks, etc)
my $schema = $self->schema;
my $schema_class = $self->schema_class;
- my $table_class = $self->classes->{$table};
+ my $table_class = $self->classes->{$table};
my $table_moniker = $self->monikers->{$table};
my $table_name = $table;
$self->_dbic_stmt($table_class, 'table', $full_table_name);
- my $cols = $self->_table_columns($table);
+ my $cols = $self->_table_columns($table);
my $col_info = $self->__columns_info_for($table);
+ ### generate all the column accessor names
while (my ($col, $info) = each %$col_info) {
- if ($col =~ /\W/) {
- ($info->{accessor} = $col) =~ s/\W+/_/g;
- }
- }
+ # hashref of other info that could be used by
+ # user-defined accessor map functions
+ my $context = {
+ table_class => $table_class,
+ table_moniker => $table_moniker,
+ table_name => $table_name,
+ full_table_name => $full_table_name,
+ schema_class => $schema_class,
+ column_info => $info,
+ };
- if ($self->preserve_case) {
- while (my ($col, $info) = each %$col_info) {
- if ($col ne lc($col)) {
- if ((not exists $self->naming->{column_accessors}) || (($self->naming->{column_accessors} =~ /(\d+)/)[0] >= 7)) {
- $info->{accessor} = $self->_make_column_accessor_name($info->{accessor} || $col);
- }
- else {
- $info->{accessor} = lc($info->{accessor} || $col);
- }
- }
- }
- }
- else {
- # XXX this needs to go away
- $col_info = { map { lc($_), $col_info->{$_} } keys %$col_info };
+ $info->{accessor} = $self->_make_column_accessor_name( $col, $context );
}
- $self->_resolve_col_accessor_collisions($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);
sub _table2moniker {
my ( $self, $table ) = @_;
- my $moniker;
+ $self->_run_user_map(
+ $self->moniker_map,
+ sub { $self->_default_table2moniker( shift ) },
+ $table
+ );
+}
- if( ref $self->moniker_map eq 'HASH' ) {
- $moniker = $self->moniker_map->{$table};
- }
- elsif( ref $self->moniker_map eq 'CODE' ) {
- $moniker = $self->moniker_map->($table);
- }
+sub _load_relationships {
+ my ($self, $tables) = @_;
- $moniker ||= $self->_default_table2moniker($table);
+ my @tables;
- return $moniker;
-}
+ foreach my $table (@$tables) {
+ my $tbl_fk_info = $self->_table_fk_info($table);
+ foreach my $fkdef (@$tbl_fk_info) {
+ $fkdef->{remote_source} =
+ $self->monikers->{delete $fkdef->{remote_table}};
+ }
+ my $tbl_uniq_info = $self->_table_uniq_info($table);
-sub _load_relationships {
- my ($self, $table) = @_;
+ my $local_moniker = $self->monikers->{$table};
- my $tbl_fk_info = $self->_table_fk_info($table);
- foreach my $fkdef (@$tbl_fk_info) {
- $fkdef->{remote_source} =
- $self->monikers->{delete $fkdef->{remote_table}};
+ push @tables, [ $local_moniker, $tbl_fk_info, $tbl_uniq_info ];
}
- my $tbl_uniq_info = $self->_table_uniq_info($table);
- my $local_moniker = $self->monikers->{$table};
- my $rel_stmts = $self->_relbuilder->generate_code($local_moniker, $tbl_fk_info, $tbl_uniq_info);
+ my $rel_stmts = $self->_relbuilder->generate_code(\@tables);
foreach my $src_class (sort keys %$rel_stmts) {
my $src_stmts = $rel_stmts->{$src_class};
}
}
+sub _load_roles {
+ my ($self, $table) = @_;
+
+ my $table_moniker = $self->monikers->{$table};
+ my $table_class = $self->classes->{$table};
+
+ my @roles = @{ $self->result_roles || [] };
+ push @roles, @{ $self->result_roles_map->{$table_moniker} }
+ if exists $self->result_roles_map->{$table_moniker};
+
+ if (@roles) {
+ $self->_pod_class_list($table_class, 'L<Moose> ROLES APPLIED', @roles);
+
+ $self->_with($table_class, @roles);
+ }
+}
+
# Overload these in driver class:
# Returns an arrayref of column names
} elsif ( $method eq 'add_columns' ) {
$self->_pod( $class, "=head1 ACCESSORS" );
my $col_counter = 0;
- my @cols = @_;
+ my @cols = @_;
while( my ($name,$attrs) = splice @cols,0,2 ) {
- $col_counter++;
+ $col_counter++;
$self->_pod( $class, '=head2 ' . $name );
- $self->_pod( $class,
- join "\n", map {
- my $s = $attrs->{$_};
- $s = !defined $s ? 'undef' :
- length($s) == 0 ? '(empty string)' :
- ref($s) eq 'SCALAR' ? $$s :
- ref($s) ? dumper_squashed $s :
- looks_like_number($s) ? $s :
- qq{'$s'}
- ;
-
- " $_: $s"
- } sort keys %$attrs,
- );
-
- if (my $comment = $self->__column_comment($self->{_class2table}{$class}, $col_counter)) {
- $self->_pod( $class, $comment );
- }
+ $self->_pod( $class,
+ join "\n", map {
+ my $s = $attrs->{$_};
+ $s = !defined $s ? 'undef' :
+ length($s) == 0 ? '(empty string)' :
+ ref($s) eq 'SCALAR' ? $$s :
+ ref($s) ? dumper_squashed $s :
+ looks_like_number($s) ? $s : qq{'$s'};
+
+ " $_: $s"
+ } sort keys %$attrs,
+ );
+ if (my $comment = $self->__column_comment($self->{_class2table}{$class}, $col_counter, $name)) {
+ $self->_pod( $class, $comment );
+ }
}
$self->_pod_cut( $class );
} elsif ( $method =~ /^(belongs_to|has_many|might_have)$/ ) {
}
}
+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, $class, $base_class) = @_;
+
+ return unless $self->generate_pod;
+
+ $self->_pod($class, "=head1 BASE CLASS: L<$base_class>");
+ $self->_pod_cut($class);
+}
+
sub _filter_comment {
my ($self, $txt) = @_;
sub _unregister_source_for_table {
my ($self, $table) = @_;
- eval {
+ try {
local $@;
my $schema = $self->schema;
# in older DBIC it's a private method
contain multiple entries per table for the original and normalized table
names, as above in L</monikers>.
+=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>
projects / dbsrgits/DBIx-Class-Schema-Loader.git / blobdiff