From: Rafael Kitover Date: Mon, 16 May 2011 08:00:38 +0000 (-0400) Subject: handle "use warnings FATAL => 'all' and set use_namespaces=1 for dynamic schemas... X-Git-Tag: 0.07011~123 X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=0f21885a9a4e44bb0d4574617cee75db076a4306;p=dbsrgits%2FDBIx-Class-Schema-Loader.git handle "use warnings FATAL => 'all' and set use_namespaces=1 for dynamic schemas not in backcompat mode (RT#59849) --- diff --git a/Changes b/Changes index ecdc4a9..0c47dd0 100644 --- a/Changes +++ b/Changes @@ -4,6 +4,12 @@ Revision history for Perl extension DBIx::Class::Schema::Loader filesystems (OSX and Windows) - support for DBD::Firebird - support for unicode Firebird data types + - handle "use warnings FATAL => 'all';" in custom/external content + (RT#59849) + - for dynamic schemas, if the schema is loaded in backcompat mode, or + naming => { monikers => 'v4' } is not explicitly set, will + automatically turn on use_namespaces=1 as well. Set use_namespaces=0 + to disable this behavior (RT#59849) 0.07010 2011-03-04 08:26:31 - add result_component_map option diff --git a/lib/DBIx/Class/Schema/Loader/Base.pm b/lib/DBIx/Class/Schema/Loader/Base.pm index fd48d40..969ed30 100644 --- a/lib/DBIx/Class/Schema/Loader/Base.pm +++ b/lib/DBIx/Class/Schema/Loader/Base.pm @@ -18,7 +18,7 @@ use Class::Unload; use Class::Inspector (); use Scalar::Util 'looks_like_number'; use File::Slurp 'slurp'; -use DBIx::Class::Schema::Loader::Utils qw/split_name dumper_squashed eval_without_redefine_warnings/; +use DBIx::Class::Schema::Loader::Utils qw/split_name dumper_squashed eval_package_without_redefine_warnings class_path/; use DBIx::Class::Schema::Loader::Optional::Dependencies (); use Try::Tiny; use DBIx::Class (); @@ -713,8 +713,6 @@ 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 @@ -726,6 +724,11 @@ EOF $self->naming->{relationships} ||= 'v4'; $self->naming->{monikers} ||= 'v4'; + if ((not defined $self->use_namespaces) + && $self->naming->{monikers} ne 'v4') { + $self->use_namespaces(1); + } + if ($self->use_namespaces) { $self->_upgrading_from_load_classes(1); } @@ -877,20 +880,10 @@ sub _find_file_in_inc { 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 { @@ -944,7 +937,7 @@ sub _load_external { my $code = $self->_rewrite_old_classnames(scalar slurp $real_inc_path); if ($self->dynamic) { # load the class too - eval_without_redefine_warnings($code); + eval_package_without_redefine_warnings($class, $code); } $self->_ext_stmt($class, @@ -985,7 +978,7 @@ 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 - eval_without_redefine_warnings($code); + eval_package_without_redefine_warnings($class, $code); } chomp $code; @@ -1212,12 +1205,10 @@ sub _moose_metaclass { 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 try { - eval_without_redefine_warnings ("require $class"); + eval_package_without_redefine_warnings ($class, "require $class"); } catch { my $source = slurp $self->_get_dump_filename($class); diff --git a/lib/DBIx/Class/Schema/Loader/Utils.pm b/lib/DBIx/Class/Schema/Loader/Utils.pm index f67988f..22a2194 100644 --- a/lib/DBIx/Class/Schema/Loader/Utils.pm +++ b/lib/DBIx/Class/Schema/Loader/Utils.pm @@ -8,7 +8,7 @@ use Test::More; use namespace::clean; use Exporter 'import'; -our @EXPORT_OK = qw/split_name dumper dumper_squashed eval_without_redefine_warnings warnings_exist warnings_exist_silent/; +our @EXPORT_OK = qw/split_name dumper dumper_squashed eval_package_without_redefine_warnings class_path warnings_exist warnings_exist_silent/; use constant BY_CASE_TRANSITION => qr/(?<=[[:lower:]\d])[\W_]*(?=[[:upper:]])|[\W_]+/; @@ -38,16 +38,50 @@ sub dumper_squashed($) { return $dd->Values([ $val ])->Dump; } -sub eval_without_redefine_warnings { - my $code = shift; +sub eval_package_without_redefine_warnings { + my ($pkg, $code) = @_; my $warn_handler = $SIG{__WARN__} || sub { warn @_ }; + local $SIG{__WARN__} = sub { $warn_handler->(@_) unless $_[0] =~ /^Subroutine \S+ redefined/; }; - eval $code; - die $@ if $@; + + # This hairiness is to handle people using "use warnings FATAL => 'all';" + # in their custom or external content. + my @delete_syms; + my $try_again = 1; + + while ($try_again) { + eval $code; + + if (my ($sym) = $@ =~ /^Subroutine (\S+) redefined/) { + delete $INC{ +class_path($pkg) }; + push @delete_syms, $sym; + + foreach my $sym (@delete_syms) { + no strict 'refs'; + undef *{"${pkg}::${sym}"}; + } + } + elsif ($@) { + die $@ if $@; + } + else { + $try_again = 0; + } + } +} + +sub class_path { + my $class = shift; + + my $class_path = $class; + $class_path =~ s{::}{/}g; + $class_path .= '.pm'; + + return $class_path; } sub warnings_exist(&$$) { diff --git a/t/50addl_base_classes.t b/t/50addl_base_classes.t new file mode 100644 index 0000000..9080ed7 --- /dev/null +++ b/t/50addl_base_classes.t @@ -0,0 +1,127 @@ +# test for loading additional methods from file-defined packages +# by Mark Hedges ( hedges -at| scriptdolphin.com ) + +use strict; +use Test::More tests => 7 * 5; +use Test::Exception; + +use lib 't/lib'; + +use make_dbictest_db; + +use DBIx::Class::Schema::Loader; + +$ENV{SCHEMA_LOADER_BACKCOMPAT} = 1; + +# In the first test run, then, Foo should be a DBICTestMethods::Namespaces::Schema::Result::Foo + +run_test_sequence( + testname => "naming => 'current'", + schema_class => 'DBICTestMethods::Namespaces::Schema', + foo_class => 'DBICTestMethods::Namespaces::Schema::Result::Foo', + schema_opts => { + naming => 'current', + }, +); + +# In the second test run with use_namespaces => 0 (backcompat), Foo should be a DBICTestMethods::Backcompat::Schema + +run_test_sequence( + testname => "naming => 'current', use_namespaces => 0", + schema_class => 'DBICTestMethods::Backcompat::Schema', + foo_class => 'DBICTestMethods::Backcompat::Schema::Foo', + schema_opts => { + naming => 'current', + use_namespaces => 0, + }, +); + +# In the third test, with use_namespaces => 1, Foo gets the explicit Result class again + +run_test_sequence( + testname => "naming => 'current', use_namespaces => 1", + schema_class => 'DBICTestMethods::Namespaces::Schema', + foo_class => 'DBICTestMethods::Namespaces::Schema::Result::Foo', + schema_opts => { + naming => 'current', + use_namespaces => 1, + }, +); + +# try it in full backcompat 0.04006 mode with no schema options + +run_test_sequence( + testname => "no naming or namespaces options (0.04006 mode)", + schema_class => 'DBICTestMethods::Backcompat::Schema', + foo_class => 'DBICTestMethods::Backcompat::Schema::Foo', + schema_opts => { + }, +); + +# try it in backcompat mode (no naming option) but with use_namespaces => 1 + +run_test_sequence( + testname => "no naming, but with use_namespaces options (0.04006 mode)", + schema_class => 'DBICTestMethods::Namespaces::Schema', + foo_class => 'DBICTestMethods::Namespaces::Schema::Result::Foo', + schema_opts => { + use_namespaces => 1, + }, +); + +sub run_test_sequence { + my %p = @_; + die "specify a $_ test param" for grep !$p{$_}, + qw( testname schema_opts schema_class foo_class ); + + my $schema; + lives_ok { $schema = make_schema_with(%p) } "($p{testname}) get schema"; + + SKIP: { + skip 'no point in checking if schema could not be connected', 6 unless defined $schema; + + # well, if that worked, try to get a ResultSet + my $foo_rs; + lives_ok { + $foo_rs = $schema->resultset('Foo')->search(); + } "($p{testname}) get a ResultSet for Foo"; + + # get a foo + my $foo; + lives_ok { + $foo = $foo_rs->first(); + } "($p{testname}) get the first foo"; + + ok(defined $foo, "($p{testname}) \$foo is defined"); + + SKIP: { + skip 'foo is not defined', 3 unless defined $foo; + + isa_ok $foo, $p{foo_class}; + + # call the file-defined method + my $biz; + lives_ok { + $biz = $foo->biz(); + } "($p{testname}) call the file-defined Foo->biz method"; + + SKIP: { + skip 'no point in checking value if method was not found', 1 unless defined $biz; + + ok( + $biz eq 'foo bar biz baz boz noz schnozz', + "($p{testname}) biz() method returns correct string" + ); + } + } + } +} + +sub make_schema_with { + my %p = @_; + return DBIx::Class::Schema::Loader::make_schema_at( + $p{schema_class}, + $p{schema_opts}, + [ $make_dbictest_db::dsn ], + ); +} diff --git a/t/lib/DBICTestMethods/Backcompat/Schema/Foo.pm b/t/lib/DBICTestMethods/Backcompat/Schema/Foo.pm new file mode 100644 index 0000000..9693012 --- /dev/null +++ b/t/lib/DBICTestMethods/Backcompat/Schema/Foo.pm @@ -0,0 +1,12 @@ +package DBICTestMethods::Backcompat::Schema::Foo; + +use strict; +use warnings FATAL => 'all'; +use English '-no_match_vars'; + +sub biz { + my ($self) = @_; + return 'foo bar biz baz boz noz schnozz'; +} + +1; diff --git a/t/lib/DBICTestMethods/Namespaces/Schema/Result/Foo.pm b/t/lib/DBICTestMethods/Namespaces/Schema/Result/Foo.pm new file mode 100644 index 0000000..277c506 --- /dev/null +++ b/t/lib/DBICTestMethods/Namespaces/Schema/Result/Foo.pm @@ -0,0 +1,12 @@ +package DBICTestMethods::Namespaces::Schema::Result::Foo; + +use strict; +use warnings FATAL => 'all'; +use English '-no_match_vars'; + +sub biz { + my ($self) = @_; + return 'foo bar biz baz boz noz schnozz'; +} + +1;