use strict;
use warnings;
-use base qw/Class::Accessor::Fast Class::C3::Componentised/;
+use base qw/Class::Accessor::Grouped Class::C3::Componentised/;
use Class::C3;
use Carp::Clan qw/^DBIx::Class/;
use DBIx::Class::Schema::Loader::RelBuilder;
our $VERSION = '0.04999_12';
-__PACKAGE__->mk_ro_accessors(qw/
+__PACKAGE__->mk_group_ro_accessors('inherited', qw/
schema
schema_class
db_schema
_tables
classes
+ _upgrading_classes
monikers
dynamic
naming
- /);
+/);
+
-__PACKAGE__->mk_accessors(qw/
+__PACKAGE__->mk_group_accessors('inherited', qw/
version_to_dump
schema_version_to_dump
+ _upgrading_from
/);
=head1 NAME
returns a false value, the code falls back to default behavior
for that table name.
-The default behavior is: 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:
+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
---------------------------
=cut
+use constant CURRENT_V => 'v5';
+
# ensure that a peice of object data is a valid arrayref, creating
# an empty one or encapsulating whatever's there.
sub _ensure_arrayref {
$self->{monikers} = {};
$self->{classes} = {};
+ $self->{_upgrading_classes} = {};
$self->{schema_class} ||= ( ref $self->{schema} || $self->{schema} );
$self->{schema} ||= $self->{schema_class};
$self->version_to_dump($DBIx::Class::Schema::Loader::VERSION);
$self->schema_version_to_dump($DBIx::Class::Schema::Loader::VERSION);
- if (not ref $self->naming && defined $self->naming) {
- my $naming_ver = $self->naming;;
+ if ((not ref $self->naming) && defined $self->naming) {
+ my $naming_ver = $self->naming;
$self->{naming} = {
relationships => $naming_ver,
monikers => $naming_ver,
};
}
+ if ($self->naming) {
+ for (values %{ $self->naming }) {
+ $_ = CURRENT_V if $_ eq 'current';
+ }
+ }
+ $self->{naming} ||= {};
+
$self->_check_back_compat;
$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 }) {
+ 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.
+
+See perldoc DBIx::Class::Schema::Loader::Manual::UpgradingFromV4 for more
+details.
+EOF
+ }
+ else {
+ $self->_upgrading_from('v4');
+ }
+
$self->naming->{relationships} ||= 'v4';
$self->naming->{monikers} ||= 'v4';
if (/^# Created by DBIx::Class::Schema::Loader v((\d+)\.(\d+))/) {
my $real_ver = $1;
- $self->schema_version_to_dump($real_ver);
-
# XXX when we go past .0 this will need fixing
my ($v) = $real_ver =~ /([1-9])/;
$v = "v$v";
+ last if $v eq CURRENT_V || $real_ver =~ /^0\.04999/;
+
+ if (not %{ $self->naming }) {
+ warn <<"EOF" unless $ENV{SCHEMA_LOADER_BACKCOMPAT};
+
+Version $real_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);
+ }
+
$self->naming->{relationships} ||= $v;
$self->naming->{monikers} ||= $v;
+ $self->schema_version_to_dump($real_ver);
+
last;
}
}
my $fullpath = File::Spec->catfile($prefix, $file);
return $fullpath if -f $fullpath
and Cwd::abs_path($fullpath) ne
- Cwd::abs_path(File::Spec->catfile($self->dump_directory, $file)) || '';
+ (Cwd::abs_path(File::Spec->catfile($self->dump_directory, $file)) || '');
}
return;
sub _load_external {
my ($self, $class) = @_;
+ # so that we don't load our own classes, under any circumstances
+ local *INC = [ grep $_ ne $self->dump_directory, @INC ];
+
my $real_inc_path = $self->_find_class_in_inc($class);
- return if !$real_inc_path;
-
- # If we make it to here, we loaded an external definition
- 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: $!";
- $self->_ext_stmt($class,
- qq|# These lines were loaded from '$real_inc_path' found in \@INC.\n|
- .qq|# They are now part of the custom portion of this file\n|
- .qq|# for you to hand-edit. If you do not either delete\n|
- .qq|# this section or remove that file from \@INC, this section\n|
- .qq|# will be repeated redundantly when you re-create this\n|
- .qq|# file again via Loader!\n|
- );
- while(<$fh>) {
- chomp;
- $self->_ext_stmt($class, $_);
+ my $old_class = $self->_upgrading_classes->{$class}
+ if $self->_upgrading_from;
+
+ my $old_real_inc_path = $self->_find_class_in_inc($old_class)
+ if $old_class && $old_class ne $class;
+
+ return unless $real_inc_path || $old_real_inc_path;
+
+ if ($real_inc_path) {
+ # If we make it to here, we loaded an external definition
+ 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: $!";
+ $self->_ext_stmt($class,
+ qq|# These lines were loaded from '$real_inc_path' found in \@INC.\n|
+ .qq|# They are now part of the custom portion of this file\n|
+ .qq|# for you to hand-edit. If you do not either delete\n|
+ .qq|# this section or remove that file from \@INC, this section\n|
+ .qq|# will be repeated redundantly when you re-create this\n|
+ .qq|# file again via Loader!\n|
+ );
+ while(<$fh>) {
+ chomp;
+ $self->_ext_stmt($class, $_);
+ }
+ $self->_ext_stmt($class,
+ qq|# End of lines loaded from '$real_inc_path' |
+ );
+ close($fh)
+ or croak "Failed to close $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/;
+ };
+ do $real_inc_path;
+ die $@ if $@;
+ }
}
- $self->_ext_stmt($class,
- qq|# End of lines loaded from '$real_inc_path' |
- );
- close($fh)
- or croak "Failed to close $real_inc_path: $!";
- if ($self->dynamic) { # load the class too
- # turn off redefined warnings
- local $SIG{__WARN__} = sub {};
- do $real_inc_path;
- die $@ if $@;
+ if ($old_real_inc_path) {
+ open(my $fh, '<', $old_real_inc_path)
+ or croak "Failed to open '$old_real_inc_path' for reading: $!";
+ $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 version of the Loader. For a
+# static schema, this happens only once during upgrade.
+EOF
+ 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.
+
+* 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/;
+ };
+ my $code = do {
+ local ($/, @ARGV) = (undef, $old_real_inc_path); <>
+ };
+ $code =~ s/$old_class/$class/g;
+ eval $code;
+ die $@ if $@;
+ }
+
+ while(<$fh>) {
+ chomp;
+ $self->_ext_stmt($class, $_);
+ }
+ $self->_ext_stmt($class,
+ qq|# End of lines loaded from '$old_real_inc_path' |
+ );
+
+ close($fh)
+ or croak "Failed to close $old_real_inc_path: $!";
}
}
}
sub _relbuilder {
+ no warnings 'uninitialized';
my ($self) = @_;
return if $self->{skip_relationships};
$self->{quiet} = 0;
# Remove that temp dir from INC so it doesn't get reloaded
- @INC = grep { $_ ne $self->{dump_directory} } @INC;
+ @INC = grep $_ ne $self->dump_directory, @INC;
}
$self->_load_external($_)
my $class_path = $self->_class_path($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/;
+ };
eval "require $class;";
}
my ($custom_content, $old_md5, $old_ver, $old_ts) = $self->_get_custom_content($class, $filename);
+ if ($self->_upgrading_from) {
+ my $old_class = $self->_upgrading_classes->{$class};
+
+ if ($old_class && ($old_class ne $class)) {
+ my $old_filename = $self->_get_dump_filename($old_class);
+
+ my ($old_custom_content) = $self->_get_custom_content(
+ $old_class, $old_filename, 0 # do not add default comment
+ );
+
+ $old_custom_content =~ s/\n\n# You can replace.*\n1;\n//;
+
+ if ($old_custom_content) {
+ $custom_content =
+ "\n" . $old_custom_content . "\n" . $custom_content;
+ }
+
+ unlink $old_filename;
+ }
+ }
+
$text .= qq|$_\n|
for @{$self->{_dump_storage}->{$class} || []};
}
sub _get_custom_content {
- my ($self, $class, $filename) = @_;
+ my ($self, $class, $filename, $add_default) = @_;
+
+ $add_default = 1 unless defined $add_default;
return ($self->_default_custom_content) if ! -f $filename;
if !$md5;
# Default custom content:
- $buffer ||= $self->_default_custom_content;
+ $buffer ||= $self->_default_custom_content if $add_default;
return ($buffer, $md5, $ver, $ts);
}
}
my $table_class = join(q{::}, @result_namespace, $table_moniker);
+ if (my $upgrading_v = $self->_upgrading_from) {
+ local $self->naming->{monikers} = $upgrading_v;
+
+ my $old_class = join(q{::}, @result_namespace,
+ $self->_table2moniker($table));
+
+ $self->_upgrading_classes->{$table_class} = $old_class;
+ }
+
my $table_normalized = lc $table;
$self->classes->{$table} = $table_class;
$self->classes->{$table_normalized} = $table_class;
# Make a moniker from a table
sub _default_table2moniker {
+ no warnings 'uninitialized';
my ($self, $table) = @_;
if ($self->naming->{monikers} eq 'v4') {
sub _is_case_sensitive { 0 }
+# remove the dump dir from @INC on destruction
+sub DESTROY {
+ my $self = shift;
+
+ @INC = grep $_ ne $self->dump_directory, @INC;
+}
+
=head2 monikers
Returns a hashref of loaded table to moniker mappings. There will
=head1 AUTHOR
-See L<DBIx::Class::Schema::Loader/CONTRIBUTORS>.
+See L<DBIx::Class::Schema::Loader/AUTHOR> and L<DBIx::Class::Schema::Loader/CONTRIBUTORS>.
=head1 LICENSE