use strict;
use warnings;
use base qw/Class::Accessor::Grouped Class::C3::Componentised/;
-use namespace::autoclean;
-use Class::C3;
+use mro 'c3';
use Carp::Clan qw/^DBIx::Class/;
use DBIx::Class::Schema::Loader::RelBuilder;
use Data::Dump qw/ dump /;
use Cwd qw//;
use Digest::MD5 qw//;
use Lingua::EN::Inflect::Number qw//;
+use Lingua::EN::Inflect::Phrase qw//;
use File::Temp qw//;
use Class::Unload;
use Class::Inspector ();
-use Data::Dumper::Concise;
use Scalar::Util 'looks_like_number';
use File::Slurp 'slurp';
-require DBIx::Class;
+use DBIx::Class::Schema::Loader::Utils qw/split_name dumper_squashed eval_without_redefine_warnings/;
+use DBIx::Class::Schema::Loader::Optional::Dependencies ();
+use Try::Tiny;
+use DBIx::Class ();
+use Class::Load 'load_class';
+use namespace::clean;
-our $VERSION = '0.05003';
+our $VERSION = '0.07004';
__PACKAGE__->mk_group_ro_accessors('simple', qw/
schema
additional_base_classes
left_base_classes
components
- resultset_components
skip_relationships
skip_load_external
moniker_map
+ column_accessor_map
custom_column_info
inflect_singular
inflect_plural
default_resultset_class
schema_base_class
result_base_class
- overwrite_modifications
+ use_moose
+ overwrite_modifications
relationship_attrs
datetime_timezone
datetime_locale
config_file
+ loader_class
+ qualify_objects
/);
generate_pod
pod_comment_mode
pod_comment_spillover_length
+ preserve_case
+ col_collision_map
+ rel_collision_map
+ real_dump_directory
+ datetime_undef_if_invalid
+ _result_class_methods
/);
=head1 NAME
=head2 naming
-Static schemas (ones dumped to disk) will, by default, use the new-style 0.05XXX
+Static schemas (ones dumped to disk) will, by default, use the new-style
relationship names and singularized Results, unless you're overwriting an
-existing dump made by a 0.04XXX version of L<DBIx::Class::Schema::Loader>, in
-which case the backward compatible RelBuilder will be activated, and
-singularization will be turned off.
+existing dump made by an older version of L<DBIx::Class::Schema::Loader>, in
+which case the backward compatible RelBuilder will be activated, and the
+appropriate monikerization used.
Specifying
- naming => 'v5'
+ naming => 'current'
will disable the backward-compatible RelBuilder and use
the new-style relationship names along with singularized Results, even when
The option also takes a hashref:
- naming => { relationships => 'v5', monikers => 'v4' }
+ naming => { relationships => 'v7', monikers => 'v7' }
The keys are:
How to name Result classes.
+=item column_accessors
+
+How to name column accessors in Result classes.
+
=back
The values can be:
=item current
-Latest default style, whatever that happens to be.
+Latest style, whatever that happens to be.
+
+=item v4
+
+Unsingularlized monikers, C<has_many> only relationships with no _id stripping.
=item v5
-Version 0.05XXX style.
+Monikers singularized as whole words, C<might_have> relationships for FKs on
+C<UNIQUE> constraints, C<_id> stripping for belongs_to relationships.
-=item v4
+Some of the C<_id> stripping edge cases in C<0.05003> have been reverted for
+the v5 RelBuilder.
+
+=item v6
+
+All monikers and relationships are inflected using
+L<Lingua::EN::Inflect::Phrase>, and there is more aggressive C<_id> stripping
+from relationship names.
+
+In general, there is very little difference between v5 and v6 schemas.
-Version 0.04XXX style.
+=item v7
+
+This mode is identical to C<v6> mode, except that monikerization of CamelCase
+table names is also done correctly.
+
+CamelCase column names in case-preserving mode will also be handled correctly
+for relationship name inflection. 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.
=back
__PACKAGE__->naming('current');
-Or if you prefer to use 0.05XXX features but insure that nothing breaks in the
+Or if you prefer to use 0.07XXX features but insure that nothing breaks in the
next major version upgrade:
- __PACKAGE__->naming('v5');
+ __PACKAGE__->naming('v7');
=head2 generate_pod
For example:
relationship_attrs => {
- all => { cascade_delete => 0 },
- has_many => { cascade_delete => 1 },
+ belongs_to => { is_deferrable => 0 },
},
-will set the C<cascade_delete> option to 0 for all generated relationships,
-except for C<has_many>, which will have cascade_delete as 1.
-
-NOTE: this option is not supported if v4 backward-compatible naming is
-set either globally (naming => 'v4') or just for relationships.
+use this to turn off DEFERRABLE on your foreign key constraints.
=head2 debug
returns a false value, the code falls back to default behavior
for that table name.
-The default behavior is to singularize the table name, and: C<join '', map
-ucfirst, split /[\W_]+/, lc $table>, which is to say: lowercase everything,
-split up the table name into chunks anywhere a non-alpha-numeric character
-occurs, change the case of first letter of each chunk to upper case, and put
-the chunks back together. Examples:
-
- Table Name | Moniker Name
- ---------------------------
- luser | Luser
- luser_group | LuserGroup
- luser-opts | LuserOpt
+The default behavior is to split on case transition and non-alphanumeric
+boundaries, singularize the resulting phrase, then join the titlecased words
+together. Examples:
+
+ Table Name | Moniker Name
+ ---------------------------------
+ luser | Luser
+ luser_group | LuserGroup
+ luser-opts | LuserOpt
+ stations_visited | StationVisited
+ routeChange | RouteChange
+
+=head2 column_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
=head2 components
List of additional components to be loaded into all of your table
-classes. A good example would be C<ResultSetManager>.
-
-=head2 resultset_components
-
-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.
+classes. A good example would be
+L<InflateColumn::DateTime|DBIx::Class::InflateColumn::DateTime>
=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.
-=head1 config_file
+=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
loader options.
+=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.
+
+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.
+
+=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.
+
+=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.
+
+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
=cut
-my $CURRENT_V = 'v5';
+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
+ left_base_classes additional_classes components
);
# ensure that a peice of object data is a valid arrayref, creating
my $self = { %args };
+ # don't lose undef options
+ for (values %$self) {
+ $_ = 0 unless defined $_;
+ }
+
bless $self => $class;
if (my $config_file = $self->config_file) {
additional_base_classes
left_base_classes
components
- resultset_components
/);
$self->_validate_class_args;
- push(@{$self->{components}}, 'ResultSetManager')
- if @{$self->{resultset_components}};
+ 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",
+ DBIx::Class::Schema::Loader::Optional::Dependencies->req_missing_for('use_moose');
+ }
+ }
$self->{monikers} = {};
$self->{classes} = {};
$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);
$self->{naming} = {
relationships => $naming_ver,
monikers => $naming_ver,
+ column_accessors => $naming_ver,
};
}
$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;
}
my $filename = $self->_get_dump_filename($self->schema_class);
return unless -e $filename;
- open(my $fh, '<', $filename)
- or croak "Cannot open '$filename' for reading: $!";
+ my ($old_gen, $old_md5, $old_ver, $old_ts, $old_custom) =
+ $self->_parse_generated_file($filename);
+
+ return unless $old_ver;
- my $load_classes = 0;
- my $result_namespace = '';
+ # 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;
+ }
- while (<$fh>) {
- if (/^__PACKAGE__->load_classes;/) {
- $load_classes = 1;
- } elsif (/result_namespace => '([^']+)'/) {
- $result_namespace = $1;
- } elsif (my ($real_ver) =
- /^# Created by DBIx::Class::Schema::Loader v(\d+\.\d+)/) {
+ my $load_classes = ($old_gen =~ /^__PACKAGE__->load_classes;/m) ? 1 : 0;
+ my $result_namespace = do { ($old_gen =~ /result_namespace => '([^']+)'/) ? $1 : '' };
- if ($load_classes && (not defined $self->use_namespaces)) {
- warn <<"EOF" unless $ENV{SCHEMA_LOADER_BACKCOMPAT};
+ if ($load_classes && (not defined $self->use_namespaces)) {
+ warn <<"EOF" unless $ENV{SCHEMA_LOADER_BACKCOMPAT};
'load_classes;' static schema detected, turning off 'use_namespaces'.
See perldoc DBIx::Class::Schema::Loader::Manual::UpgradingFromV4 for more
details.
EOF
- $self->use_namespaces(0);
- }
- elsif ($load_classes && $self->use_namespaces) {
- $self->_upgrading_from_load_classes(1);
- }
- elsif ((not $load_classes) && defined $self->use_namespaces
- && (not $self->use_namespaces)) {
- $self->_downgrading_to_load_classes(
- $result_namespace || 'Result'
- );
- }
- elsif ((not defined $self->use_namespaces)
- || $self->use_namespaces) {
- if (not $self->result_namespace) {
- $self->result_namespace($result_namespace || 'Result');
- }
- elsif ($result_namespace ne $self->result_namespace) {
- $self->_rewriting_result_namespace(
- $result_namespace || 'Result'
- );
- }
- }
+ $self->use_namespaces(0);
+ }
+ elsif ($load_classes && $self->use_namespaces) {
+ $self->_upgrading_from_load_classes(1);
+ }
+ elsif ((not $load_classes) && defined $self->use_namespaces && ! $self->use_namespaces) {
+ $self->_downgrading_to_load_classes(
+ $result_namespace || 'Result'
+ );
+ }
+ elsif ((not defined $self->use_namespaces) || $self->use_namespaces) {
+ if (not $self->result_namespace) {
+ $self->result_namespace($result_namespace || 'Result');
+ }
+ elsif ($result_namespace ne $self->result_namespace) {
+ $self->_rewriting_result_namespace(
+ $result_namespace || 'Result'
+ );
+ }
+ }
- # XXX when we go past .0 this will need fixing
- my ($v) = $real_ver =~ /([1-9])/;
- $v = "v$v";
+ # XXX when we go past .0 this will need fixing
+ my ($v) = $old_ver =~ /([1-9])/;
+ $v = "v$v";
- last if $v eq $CURRENT_V || $real_ver =~ /^0\.\d\d999/;
+ return if ($v eq $CURRENT_V || $old_ver =~ /^0\.\d\d999/);
- if (not %{ $self->naming }) {
- warn <<"EOF" unless $ENV{SCHEMA_LOADER_BACKCOMPAT};
+ if (not %{ $self->naming }) {
+ warn <<"EOF" unless $ENV{SCHEMA_LOADER_BACKCOMPAT};
-Version $real_ver static schema detected, turning on backcompat mode.
+Version $old_ver static schema detected, turning on backcompat mode.
Set the 'naming' attribute or the SCHEMA_LOADER_BACKCOMPAT environment variable
to disable this warning.
-See perldoc DBIx::Class::Schema::Loader::Manual::UpgradingFromV4 for more
-details.
-EOF
- }
- else {
- $self->_upgrading_from($v);
- last;
- }
+See: 'naming' in perldoc DBIx::Class::Schema::Loader::Base .
- $self->naming->{relationships} ||= $v;
- $self->naming->{monikers} ||= $v;
+See perldoc DBIx::Class::Schema::Loader::Manual::UpgradingFromV4 if upgrading
+from version 0.04006.
+EOF
- $self->schema_version_to_dump($real_ver);
+ $self->naming->{relationships} ||= $v;
+ $self->naming->{monikers} ||= $v;
+ $self->naming->{column_accessors} ||= $v;
- last;
- }
+ $self->schema_version_to_dump($old_ver);
+ }
+ else {
+ $self->_upgrading_from($v);
}
- close $fh;
}
sub _validate_class_args {
my $self = shift;
my $args = shift;
-
+
foreach my $k (@CLASS_ARGS) {
next unless $self->$k;
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;
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(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_without_redefine_warnings($code);
}
$self->_ext_stmt($class,
}
if ($old_real_inc_path) {
- open(my $fh, '<', $old_real_inc_path)
- or croak "Failed to open '$old_real_inc_path' for reading: $!";
+ my $code = slurp $old_real_inc_path;
+
$self->_ext_stmt($class, <<"EOF");
# These lines were loaded from '$old_real_inc_path',
-# based on the Result class name that would have been created by an 0.04006
+# based on the Result class name that would have been created by an older
# version of the Loader. For a static schema, this happens only once during
# upgrade. See skip_load_external to disable this feature.
EOF
- my $code = slurp $old_real_inc_path;
$code = $self->_rewrite_old_classnames($code);
if ($self->dynamic) {
warn <<"EOF";
Detected external content in '$old_real_inc_path', a class name that would have
-been used by an 0.04006 version of the Loader.
+been used by an older version of the Loader.
* PLEASE RENAME THIS CLASS: from '$old_class' to '$class', as that is the
new name of the Result.
EOF
- # 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_without_redefine_warnings($code);
}
chomp $code;
Arguments: schema
-Rescan the database for newly added tables. Does
-not process drops or changes. Returns a list of
-the newly added table monikers.
+Rescan the database for changes. Returns a list of the newly added table
+monikers.
-The schema argument should be the schema class
-or object to be affected. It should probably
-be derived from the original schema_class used
-during L</load>.
+The schema argument should be the schema class or object to be affected. It
+should probably be derived from the original schema_class used during L</load>.
=cut
my @created;
my @current = $self->_tables_list({ constraint => $self->constraint, exclude => $self->exclude });
+
foreach my $table (@current) {
if(!exists $self->{_tables}->{$table}) {
push(@created, $table);
}
}
- my $loaded = $self->_load_tables(@created);
+ my %current;
+ @current{@current} = ();
+ foreach my $table (keys %{ $self->{_tables} }) {
+ if (not exists $current{$table}) {
+ $self->_unregister_source_for_table($table);
+ }
+ }
+
+ delete $self->{_dump_storage};
+ delete $self->{_relations_started};
+
+ my $loaded = $self->_load_tables(@current);
- return map { $self->monikers->{$_} } @$loaded;
+ return map { $self->monikers->{$_} } @created;
}
sub _relbuilder {
- no warnings 'uninitialized';
my ($self) = @_;
return if $self->{skip_relationships};
- if ($self->naming->{relationships} eq 'v4') {
- require DBIx::Class::Schema::Loader::RelBuilder::Compat::v0_040;
- return $self->{relbuilder} ||=
- DBIx::Class::Schema::Loader::RelBuilder::Compat::v0_040->new(
- $self->schema, $self->inflect_plural, $self->inflect_singular
- );
- }
+ return $self->{relbuilder} ||= do {
- $self->{relbuilder} ||= DBIx::Class::Schema::Loader::RelBuilder->new (
- $self->schema,
- $self->inflect_plural,
- $self->inflect_singular,
- $self->relationship_attrs,
- );
+ no warnings 'uninitialized';
+ my $relbuilder_suff =
+ {qw{
+ v4 ::Compat::v0_040
+ v5 ::Compat::v0_05
+ v6 ::Compat::v0_06
+ }}
+ ->{ $self->naming->{relationships}};
+
+ my $relbuilder_class = 'DBIx::Class::Schema::Loader::RelBuilder'.$relbuilder_suff;
+ load_class $relbuilder_class;
+ $relbuilder_class->new( $self );
+
+ };
}
sub _load_tables {
local $self->{dump_directory} = $self->{temp_directory};
$self->_reload_classes(\@tables);
$self->_load_relationships($_) for @tables;
+# $self->_relbuilder->cleanup; # this breaks perl 5.8.x
$self->{quiet} = 0;
# Remove that temp dir from INC so it doesn't get reloaded
# 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
{
no warnings 'redefine';
- local *Class::C3::reinitialize = sub {};
+ local *Class::C3::reinitialize = sub {}; # to speed things up, reinitialized below
use warnings;
+ if (my $mc = $self->_moose_metaclass($class)) {
+ $mc->make_mutable;
+ }
Class::Unload->unload($class) if $unload;
my ($source, $resultset_class);
if (
&& ($resultset_class ne 'DBIx::Class::ResultSet')
) {
my $has_file = Class::Inspector->loaded_filename($resultset_class);
+ if (my $mc = $self->_moose_metaclass($resultset_class)) {
+ $mc->make_mutable;
+ }
Class::Unload->unload($resultset_class) if $unload;
$self->_reload_class($resultset_class) if $has_file;
}
}
}
+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 $class = $_[1];
+
+ my $mc = try { Class::MOP::class_of($class) }
+ or return undef;
+
+ return $mc->isa('Moose::Meta::Class') ? $mc : undef;
+}
+
# We use this instead of ensure_class_loaded when there are package symbols we
# want to preserve.
sub _reload_class {
delete $INC{ $class_path };
# kill redefined warnings
- my $warn_handler = $SIG{__WARN__} || sub { warn @_ };
- local $SIG{__WARN__} = sub {
- $warn_handler->(@_)
- unless $_[0] =~ /^Subroutine \S+ redefined/;
+ try {
+ eval_without_redefine_warnings ("require $class");
+ }
+ catch {
+ my $source = slurp $self->_get_dump_filename($class);
+ die "Failed to reload class $class: $_.\n\nCLASS SOURCE:\n\n$source";
};
- eval "require $class;";
}
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|use base '$schema_base_class';\n\n|;
+ . qq|# DO NOT MODIFY THE FIRST PART OF THIS FILE\n\n|;
+
+ if ($self->use_moose) {
+ $schema_text.= qq|use Moose;\nuse namespace::autoclean;\nextends '$schema_base_class';\n\n|;
+ }
+ else {
+ $schema_text .= qq|use strict;\nuse warnings;\n\nuse base '$schema_base_class';\n\n|;
+ }
if ($self->use_namespaces) {
$schema_text .= qq|__PACKAGE__->load_namespaces|;
my $namespace_options;
- for my $attr (qw(result_namespace
- resultset_namespace
- default_resultset_class)) {
+
+ my @attr = qw/resultset_namespace default_resultset_class/;
+
+ unshift @attr, 'result_namespace' unless (not $self->result_namespace) || $self->result_namespace eq 'Result';
+
+ for my $attr (@attr) {
if ($self->$attr) {
$namespace_options .= qq| $attr => '| . $self->$attr . qq|',\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|use base '$result_base_class';\n\n|;
+ . qq|use strict;\nuse warnings;\n\n|;
+ if ($self->use_moose) {
+ $src_text.= qq|use Moose;\nuse MooseX::NonMoose;\nuse namespace::autoclean;|;
+ # these options 'use base' which is compile time
+ if (@{ $self->left_base_classes } || @{ $self->additional_base_classes }) {
+ $src_text .= qq|\nBEGIN { extends '$result_base_class' }\n\n|;
+ }
+ else {
+ $src_text .= qq|\nextends '$result_base_class';\n\n|;
+ }
+ }
+ else {
+ $src_text .= qq|use base '$result_base_class';\n\n|;
+ }
$self->_write_classfile($src_class, $src_text);
}
warn "Deleting existing file '$filename' due to "
. "'really_erase_my_files' setting\n" unless $self->{quiet};
unlink($filename);
- }
+ }
+
+ my ($old_gen, $old_md5, $old_ver, $old_ts, $old_custom)
+ = $self->_parse_generated_file($filename);
- my ($custom_content, $old_md5, $old_ver, $old_ts) = $self->_get_custom_content($class, $filename);
+ if (! $old_gen && -f $filename) {
+ croak "Cannot overwrite '$filename' without 'really_erase_my_files',"
+ . " it does not appear to have been generated by Loader"
+ }
- if (my $old_class = $self->_upgrading_classes->{$class}) {
- my $old_filename = $self->_get_dump_filename($old_class);
+ my $custom_content = $old_custom || '';
- my ($old_custom_content) = $self->_get_custom_content(
- $old_class, $old_filename, 0 # do not add default comment
- );
+ # prepend extra custom content from a *renamed* class (singularization effect)
+ if (my $renamed_class = $self->_upgrading_classes->{$class}) {
+ my $old_filename = $self->_get_dump_filename($renamed_class);
- $old_custom_content =~ s/\n\n# You can replace.*\n1;\n//;
+ if (-f $old_filename) {
+ my $extra_custom = ($self->_parse_generated_file ($old_filename))[4];
- if ($old_custom_content) {
- $custom_content =
- "\n" . $old_custom_content . "\n" . $custom_content;
+ $extra_custom =~ s/\n\n# You can replace.*\n1;\n//;
+
+ $custom_content = join ("\n", '', $extra_custom, $custom_content)
+ if $extra_custom;
+
+ unlink $old_filename;
}
+ }
+
+ $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 ($self->use_moose) {
- unlink $old_filename;
+ my $non_moose_custom_content = do {
+ local $self->{use_moose} = 0;
+ $self->_default_custom_content;
+ };
+
+ if ($custom_content eq $non_moose_custom_content) {
+ $custom_content = $self->_default_custom_content($is_schema);
+ }
+ 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) {
return unless $self->_upgrading_from && $is_schema;
}
or croak "Error closing '$filename': $!";
}
-sub _default_custom_content {
- return qq|\n\n# You can replace this text with custom|
- . qq| content, and it will be preserved on regeneration|
- . qq|\n1;\n|;
+sub _default_moose_custom_content {
+ 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 _get_custom_content {
- my ($self, $class, $filename, $add_default) = @_;
+sub _default_custom_content {
+ 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($is_schema);
+ }
+ $default .= qq|\n1;\n|;
+ return $default;
+}
- $add_default = 1 unless defined $add_default;
+sub _parse_generated_file {
+ my ($self, $fn) = @_;
- return ($self->_default_custom_content) if ! -f $filename;
+ return unless -f $fn;
- open(my $fh, '<', $filename)
- or croak "Cannot open '$filename' for reading: $!";
+ open(my $fh, '<', $fn)
+ or croak "Cannot open '$fn' for reading: $!";
- my $mark_re =
+ my $mark_re =
qr{^(# DO NOT MODIFY THIS OR ANYTHING ABOVE! md5sum:)([A-Za-z0-9/+]{22})\n};
- my $buffer = '';
- my ($md5, $ts, $ver);
+ my ($md5, $ts, $ver, $gen);
while(<$fh>) {
- if(!$md5 && /$mark_re/) {
+ if(/$mark_re/) {
+ my $pre_md5 = $1;
$md5 = $2;
- my $line = $1;
- # Pull out the previous version and timestamp
- ($ver, $ts) = $buffer =~ m/# Created by DBIx::Class::Schema::Loader v(.*?) @ (.*?)$/s;
+ # Pull out the version and timestamp from the line above
+ ($ver, $ts) = $gen =~ m/^# Created by DBIx::Class::Schema::Loader v(.*?) @ (.*?)\Z/m;
- $buffer .= $line;
- croak "Checksum mismatch in '$filename', 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($buffer) ne $md5;
+ $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;
- $buffer = '';
+ last;
}
else {
- $buffer .= $_;
+ $gen .= $_;
}
}
- croak "Cannot not overwrite '$filename' without 'really_erase_my_files',"
- . " it does not appear to have been generated by Loader"
- if !$md5;
+ my $custom = do { local $/; <$fh> }
+ if $md5;
- # Default custom content:
- $buffer ||= $self->_default_custom_content if $add_default;
+ close ($fh);
- return ($buffer, $md5, $ver, $ts);
+ return ($gen, $md5, $ver, $ts, $custom);
}
sub _use {
sub _inject {
my $self = shift;
my $target = shift;
- my $schema_class = $self->schema_class;
my $blist = join(q{ }, @_);
- warn "$target: use base qw/ $blist /;" if $self->debug && @_;
- $self->_raw_stmt($target, "use base qw/ $blist /;") if @_;
+
+ return unless $blist;
+
+ warn "$target: use base qw/$blist/;" if $self->debug;
+ $self->_raw_stmt($target, "use base qw/$blist/;");
}
sub _result_namespace {
$self->_dbic_stmt($table_class, 'load_components', @components);
}
- $self->_dbic_stmt($table_class, 'load_resultset_components', @{$self->resultset_components})
- if @{$self->resultset_components};
$self->_inject($table_class, @{$self->additional_base_classes});
}
+sub _is_result_class_method {
+ my ($self, $name) = @_;
+
+ if (not $self->_result_class_methods) {
+ my (@methods, %methods);
+ my $base = $self->result_base_class || 'DBIx::Class::Core';
+ my @components = map { /^\+/ ? substr($_,1) : "DBIx::Class::$_" } @{ $self->components || [] };
+
+ for my $class ($base, @components, $self->use_moose ? 'Moose::Object' : ()) {
+ load_class $class;
+
+ push @methods, @{ Class::Inspector->methods($class) || [] };
+ }
+
+ push @methods, @{ Class::Inspector->methods('UNIVERSAL') };
+
+ @methods{@methods} = ();
+
+ # futureproof meta
+ $methods{meta} = undef;
+
+ $self->_result_class_methods(\%methods);
+ }
+ my $result_methods = $self->_result_class_methods;
+
+ return exists $result_methods->{$name};
+}
+
+sub _resolve_col_accessor_collisions {
+ my ($self, $table, $col_info) = @_;
+
+ my $table_name = ref $table ? $$table : $table;
+
+ while (my ($col, $info) = each %$col_info) {
+ my $accessor = $info->{accessor} || $col;
+
+ next if $accessor eq 'id'; # special case (very common column)
+
+ if ($self->_is_result_class_method($accessor)) {
+ 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;
+ }
+ }
+ }
+}
+
+# use the same logic to run moniker_map, column_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->column_accessor_map,
+ sub { $self->_default_column_accessor_name( shift ) },
+ $column_name,
+ $column_context_info,
+ );
+
+ return $accessor;
+}
+
# Set up metadata (cols, pks, etc)
sub _setup_src_meta {
my ($self, $table) = @_;
$table_name = \ $self->_quote_table_name($table_name);
}
- $self->_dbic_stmt($table_class,'table',$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;
- my $cols = $self->_table_columns($table);
+ $self->_dbic_stmt($table_class, 'table', $full_table_name);
+
+ my $cols = $self->_table_columns($table);
my $col_info = $self->__columns_info_for($table);
- if ($self->_is_case_sensitive) {
- for my $col (keys %$col_info) {
- $col_info->{$col}{accessor} = lc $col
- if $col ne lc($col);
- }
- } else {
- $col_info = { map { lc($_), $col_info->{$_} } keys %$col_info };
+
+ ### generate all the column accessor names
+ while (my ($col, $info) = each %$col_info) {
+ # 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,
+ };
+
+ $info->{accessor} = $self->_make_column_accessor_name( $col, $context );
+ }
+
+ $self->_resolve_col_accessor_collisions($full_table_name, $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);
- for my $fkdef (@$fks) {
+ foreach my $fkdef (@$fks) {
for my $col (@{ $fkdef->{local_columns} }) {
$col_info->{$col}{is_foreign_key} = 1;
}
}
+
+ my $pks = $self->_table_pk_info($table) || [];
+
+ foreach my $pkcol (@$pks) {
+ $col_info->{$pkcol}{is_nullable} = 0;
+ }
+
$self->_dbic_stmt(
$table_class,
'add_columns',
my %uniq_tag; # used to eliminate duplicate uniqs
- my $pks = $self->_table_pk_info($table) || [];
@$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
if ($self->naming->{monikers} eq 'v4') {
return join '', map ucfirst, split /[\W_]+/, lc $table;
}
+ elsif ($self->naming->{monikers} eq 'v5') {
+ return join '', map ucfirst, split /[\W_]+/,
+ Lingua::EN::Inflect::Number::to_S(lc $table);
+ }
+ elsif ($self->naming->{monikers} eq 'v6') {
+ (my $as_phrase = lc $table) =~ s/_+/ /g;
+ my $inflected = Lingua::EN::Inflect::Phrase::to_S($as_phrase);
- return join '', map ucfirst, split /[\W_]+/,
- Lingua::EN::Inflect::Number::to_S(lc $table);
-}
+ return join '', map ucfirst, split /\W+/, $inflected;
+ }
-sub _table2moniker {
- my ( $self, $table ) = @_;
+ my @words = map lc, split_name $table;
+ my $as_phrase = join ' ', @words;
- my $moniker;
+ my $inflected = Lingua::EN::Inflect::Phrase::to_S($as_phrase);
- if( ref $self->moniker_map eq 'HASH' ) {
- $moniker = $self->moniker_map->{$table};
- }
- elsif( ref $self->moniker_map eq 'CODE' ) {
- $moniker = $self->moniker_map->($table);
- }
+ return join '', map ucfirst, split /\W+/, $inflected;
+}
- $moniker ||= $self->_default_table2moniker($table);
+sub _table2moniker {
+ my ( $self, $table ) = @_;
- return $moniker;
+ $self->_run_user_map(
+ $self->moniker_map,
+ sub { $self->_default_table2moniker( shift ) },
+ $table
+ );
}
sub _load_relationships {
my ($table) = @_;
my $pcm = $self->pod_comment_mode;
my ($comment, $comment_overflows, $comment_in_name, $comment_in_desc);
- if ( $self->can('_table_comment') ) {
- $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));
- }
+ $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;
} 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) ? do {
- my $dd = Dumper;
- $dd->Indent(0);
- $dd->Values([$s]);
- $dd->Dump;
- } :
- looks_like_number($s) ? $s :
- qq{'$s'}
- ;
-
- " $_: $s"
- } sort keys %$attrs,
- );
-
- if( $self->can('_column_comment')
- and 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 _filter_comment {
+ my ($self, $txt) = @_;
+
+ $txt = '' if not defined $txt;
+
+ $txt =~ s/(?:\015?\012|\015\012?)/\n/g;
+
+ return $txt;
+}
+
+sub __table_comment {
+ my $self = shift;
+
+ if (my $code = $self->can('_table_comment')) {
+ return $self->_filter_comment($self->$code(@_));
+ }
+
+ return '';
+}
+
+sub __column_comment {
+ my $self = shift;
+
+ if (my $code = $self->can('_column_comment')) {
+ return $self->_filter_comment($self->$code(@_));
+ }
+
+ return '';
+}
+
# Stores a POD documentation
sub _pod {
my ($self, $class, $stmt) = @_;
return $qt . $table . $qt;
}
-sub _is_case_sensitive { 0 }
-
sub _custom_column_info {
my ( $self, $table_name, $column_name, $column_info ) = @_;
return $result;
}
+sub _lc {
+ my ($self, $name) = @_;
+
+ return $self->preserve_case ? $name : lc($name);
+}
+
+sub _uc {
+ my ($self, $name) = @_;
+
+ return $self->preserve_case ? $name : uc($name);
+}
+
+sub _unregister_source_for_table {
+ my ($self, $table) = @_;
+
+ try {
+ local $@;
+ my $schema = $self->schema;
+ # in older DBIC it's a private method
+ my $unregister = $schema->can('unregister_source') || $schema->can('_unregister_source');
+ $schema->$unregister($self->_table2moniker($table));
+ delete $self->monikers->{$table};
+ delete $self->classes->{$table};
+ delete $self->_upgrading_classes->{$table};
+ delete $self->{_tables}{$table};
+ };
+}
+
# remove the dump dir from @INC on destruction
sub DESTROY {
my $self = shift;
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