[Bast-commits] r5222 - in DBIx-Class/0.08/trunk: lib/DBIx/Class/Relationship t

[ash at dev.catalyst.perl.org]

Author: ash
Date: 2008-12-03 17:23:00 +0000 (Wed, 03 Dec 2008)
New Revision: 5222

Added:
   DBIx-Class/0.08/trunk/t/103many_to_many_warning.t
Modified:
   DBIx-Class/0.08/trunk/lib/DBIx/Class/Relationship/ManyToMany.pm
Log:
Make the many-to-many warning use warnings::register;

Modified: DBIx-Class/0.08/trunk/lib/DBIx/Class/Relationship/ManyToMany.pm
===================================================================
--- DBIx-Class/0.08/trunk/lib/DBIx/Class/Relationship/ManyToMany.pm	2008-12-02 19:36:37 UTC (rev 5221)
+++ DBIx-Class/0.08/trunk/lib/DBIx/Class/Relationship/ManyToMany.pm	2008-12-03 17:23:00 UTC (rev 5222)
@@ -3,6 +3,7 @@
 
 use strict;
 use warnings;
+use warnings::register;
 use Sub::Name ();
 
 sub many_to_many {
@@ -26,10 +27,18 @@
     my $rs_meth = "${meth}_rs";
 
     for ($add_meth, $remove_meth, $set_meth, $rs_meth) {
-      warn "***************************************************************************\n".
-           "The many-to-many relationship $meth is trying to create a utility method called $_. This will overwrite the existing method on $class. You almost certainly want to rename your method or the many-to-many relationship, as your method will not be callable (it will use the one from the relationship instead.) YOU HAVE BEEN WARNED\n".
-           "***************************************************************************\n"
-        if $class->can($_);
+      warnings::warn(<<"EOW")
+***************************************************************************
+The many-to-many relationship $meth is trying to create a utility method called
+$_. This will overwrite the existing method on $class. You almost certainly
+want to rename your method or the many-to-many relationship, as your method
+will not be callable (it will use the one from the relationship instead.) 
+
+no warnings 'DBIx::Class::Relationship::ManyToMany'; in 
+$class to disable.
+***************************************************************************
+EOW
+        if warnings::enabled() && $class->can($_);
     }
 
     $rel_attrs->{alias} ||= $f_rel;

Added: DBIx-Class/0.08/trunk/t/103many_to_many_warning.t
===================================================================
--- DBIx-Class/0.08/trunk/t/103many_to_many_warning.t	                        (rev 0)
+++ DBIx-Class/0.08/trunk/t/103many_to_many_warning.t	2008-12-03 17:23:00 UTC (rev 5222)
@@ -0,0 +1,91 @@
+use strict;
+use warnings;
+use Test::More;
+
+use lib qw(t/lib);
+
+
+our $no_warn = "";
+
+plan tests => 2;
+{
+  local $@; 
+  local $SIG{__WARN__} = sub { die @_ };
+  eval "@{[code()]}";
+  ok($@, "Warning triggered without relevant 'no warnings'");
+}
+
+{
+  # Clean up the packages
+  delete $INC{'DBICTest/ManyToManyWarning.pm'};
+  delete $DBICTest::{"Schema::"};
+
+  $no_warn = "no warnings 'DBIx::Class::Relationship::ManyToMany';";
+  local $SIG{__WARN__} = sub { die @_ };
+  eval "@{[code()]}";
+  ok(!$@, "No Warning triggered with relevant 'no warnings'");
+}
+
+sub code {
+my $file = << "EOF";
+use strict;
+use warnings;
+
+{
+  package #
+    DBICTest::Schema::Foo;
+  use base 'DBIx::Class::Core';
+  __PACKAGE__->table('foo');
+  __PACKAGE__->add_columns(
+    'fooid' => {
+      data_type => 'integer',
+      is_auto_increment => 1,
+    },
+  );
+  __PACKAGE__->set_primary_key('fooid');
+
+
+  __PACKAGE__->has_many('foo_to_bar' => 'DBICTest::Schema::FooToBar' => 'bar');
+  __PACKAGE__->many_to_many( foos => foo_to_bar => 'bar' );
+
+}
+{
+  package #
+    DBICTest::Schema::FooToBar;
+
+  use base 'DBIx::Class::Core';
+  __PACKAGE__->table('foo_to_bar');
+  __PACKAGE__->add_columns(
+    'foo' => {
+      data_type => 'integer',
+    },
+    'bar' => {
+      data_type => 'integer',
+    },
+  );
+  __PACKAGE__->belongs_to('foo' => 'DBICTest::Schema::Foo');
+  __PACKAGE__->belongs_to('bar' => 'DBICTest::Schema::Foo');
+}
+{
+  package #
+    DBICTest::Schema::Bar;
+  use base 'DBIx::Class::Core';
+  __PACKAGE__->table('bar');
+  __PACKAGE__->add_columns(
+    'barid' => {
+      data_type => 'integer',
+      is_auto_increment => 1,
+    },
+  );
+
+  use DBIx::Class::Relationship::ManyToMany;
+  $main::no_warn
+  __PACKAGE__->set_primary_key('barid');
+  __PACKAGE__->has_many('foo_to_bar' => 'DBICTest::Schema::FooToBar' => 'foo');
+  __PACKAGE__->many_to_many( bars => foo_to_bar => 'foo' );
+
+  sub add_to_bars {}
+}
+EOF
+  return $file;
+}