[Bast-commits] r8179 - in
branches/DBIx-Class-Schema-Loader/current: .
lib/DBIx/Class/Schema/Loader t
caelum at dev.catalyst.perl.org
caelum at dev.catalyst.perl.org
Tue Dec 29 14:38:44 GMT 2009
Author: caelum
Date: 2009-12-29 14:38:40 +0000 (Tue, 29 Dec 2009)
New Revision: 8179
Modified:
branches/DBIx-Class-Schema-Loader/current/TODO-BACKCOMPAT
branches/DBIx-Class-Schema-Loader/current/lib/DBIx/Class/Schema/Loader/Base.pm
branches/DBIx-Class-Schema-Loader/current/t/25backcompat_v4.t
Log:
load custom content from external un-singularized classes, tested for dynamic schema needs a test for static schema
Modified: branches/DBIx-Class-Schema-Loader/current/TODO-BACKCOMPAT
===================================================================
--- branches/DBIx-Class-Schema-Loader/current/TODO-BACKCOMPAT 2009-12-28 17:26:59 UTC (rev 8178)
+++ branches/DBIx-Class-Schema-Loader/current/TODO-BACKCOMPAT 2009-12-29 14:38:40 UTC (rev 8179)
@@ -2,9 +2,8 @@
*** 0.04006 mode
-* get custom content from un-singularized classes in _load_external, with an
- appropriate comment that it's during upgrade only, for both static and
- dynamic schemas
+* test getting custom content from un-singularized classes in _load_external
+ for a static schema
* make use_namespaces the default, and upgrade to it properly
Modified: branches/DBIx-Class-Schema-Loader/current/lib/DBIx/Class/Schema/Loader/Base.pm
===================================================================
--- branches/DBIx-Class-Schema-Loader/current/lib/DBIx/Class/Schema/Loader/Base.pm 2009-12-28 17:26:59 UTC (rev 8178)
+++ branches/DBIx-Class-Schema-Loader/current/lib/DBIx/Class/Schema/Loader/Base.pm 2009-12-29 14:38:40 UTC (rev 8179)
@@ -478,39 +478,94 @@
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;
+ my $old_class = $self->_upgrading_classes->{$class}
+ if $self->_upgrading_from;
- # If we make it to here, we loaded an external definition
- warn qq/# Loaded external class definition for '$class'\n/
- if $self->debug;
+ my $old_real_inc_path = $self->_find_class_in_inc($old_class)
+ if $old_class && $old_class ne $class;
- 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, $_);
+ 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
+ local $SIG{__WARN__} = sub {
+ warn @_ 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
+ local $SIG{__WARN__} = sub {
+ warn @_ 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: $!";
}
}
@@ -608,7 +663,7 @@
$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($_)
@@ -797,12 +852,16 @@
my $old_filename = $self->_get_dump_filename($old_class);
my ($old_custom_content) = $self->_get_custom_content(
- $old_class, $old_filename
+ $old_class, $old_filename, 0 # do not add default comment
);
- $custom_content .= "\n" . $old_custom_content
- if $old_custom_content;
+ $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;
}
}
@@ -851,8 +910,10 @@
}
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;
open(my $fh, '<', $filename)
@@ -887,7 +948,7 @@
if !$md5;
# Default custom content:
- $buffer ||= $self->_default_custom_content;
+ $buffer ||= $self->_default_custom_content if $add_default;
return ($buffer, $md5, $ver, $ts);
}
@@ -1195,6 +1256,13 @@
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
Modified: branches/DBIx-Class-Schema-Loader/current/t/25backcompat_v4.t
===================================================================
--- branches/DBIx-Class-Schema-Loader/current/t/25backcompat_v4.t 2009-12-28 17:26:59 UTC (rev 8178)
+++ branches/DBIx-Class-Schema-Loader/current/t/25backcompat_v4.t 2009-12-29 14:38:40 UTC (rev 8179)
@@ -3,6 +3,8 @@
use Test::More;
use File::Path qw/rmtree make_path/;
use Class::Unload;
+use File::Temp qw/tempfile tempdir/;
+use IO::File;
use lib qw(t/lib);
use make_dbictest_db2;
@@ -59,7 +61,9 @@
[qw/Foos Bar Bazs Quuxs/],
'correct monikers in 0.04006 mode';
- ok my $bar = eval { $schema->resultset('Bar')->find(1) };
+ isa_ok ((my $bar = eval { $schema->resultset('Bar')->find(1) }),
+ $res->{classes}{bar},
+ 'found a bar');
isa_ok eval { $bar->foo_id }, $res->{classes}{foos},
'correct rel name in 0.04006 mode';
@@ -130,6 +134,41 @@
run_v5_tests($res);
}
+# test upgraded dynamic schema with external content loaded
+{
+ my $temp_dir = tempdir;
+ push @INC, $temp_dir;
+
+ my $external_result_dir = join '/', $temp_dir, split /::/, $SCHEMA_CLASS;
+ make_path $external_result_dir;
+
+ IO::File->new(">$external_result_dir/Quuxs.pm")->print(<<"EOF");
+package ${SCHEMA_CLASS}::Quuxs;
+sub a_method { 'hlagh' }
+1;
+EOF
+
+ my $res = run_loader(naming => 'current');
+ my $schema = $res->{schema};
+
+ is scalar @{ $res->{warnings} }, 1,
+'correct nummber of warnings for upgraded dynamic schema with external ' .
+'content for unsingularized Result.';
+
+ my $warning = $res->{warnings}[0];
+ like $warning, qr/Detected external content/i,
+ 'detected external content warning';
+
+ is eval { $schema->resultset('Quux')->find(1)->a_method }, 'hlagh',
+'external custom content for unsingularized Result was loaded by upgraded ' .
+'dynamic Schema';
+
+ run_v5_tests($res);
+
+ rmtree $temp_dir;
+ pop @INC;
+}
+
# test running against v4 schema without upgrade
{
# write out the 0.04006 Schema.pm we have in __DATA__
@@ -153,6 +192,9 @@
like $warning, qr/DBIx::Class::Schema::Loader::Manual::UpgradingFromV4/,
'refers to upgrading doc';
+ is scalar @{ $res->{warnings} }, 3,
+ 'correct number of warnings for static schema in backcompat mode';
+
run_v4_tests($res);
# add some custom content to a Result that will be replaced
@@ -201,7 +243,9 @@
done_testing;
-END { rmtree $DUMP_DIR }
+END {
+ rmtree $DUMP_DIR unless $ENV{SCHEMA_LOADER_TESTS_NOCLEANUP};
+}
# a Schema.pm made with 0.04006
More information about the Bast-commits
mailing list