| Subject: | [PATCH] Use named subroutines |
It is useful when debugging programs that use generated accessor methods
if those methods are named rather than anonymous.
The attached patch names accessors generated by Class::Data::Inheritable
using the Sub::Name module if that is available. If it isn't available
then there is no change.
The patch is based on the code in Class::Accessor, and also incorporates
a patch on RT #6281:
http://rt.cpan.org/Public/Bug/Display.html?id=6281
to avoid overwriting existing subroutines.
| Subject: | subname.patch |
diff -ruN Class-Data-Inheritable-0.08.orig/README Class-Data-Inheritable-0.08/README
--- Class-Data-Inheritable-0.08.orig/README 2008-01-25 11:37:02.000000000 +0000
+++ Class-Data-Inheritable-0.08/README 2009-11-09 12:41:00.335444500 +0000
@@ -85,6 +85,9 @@
$self->_Suitcase_accessor(@_);
}
+ The accessor and its alias will each not be created if a subroutine of
+ the same name already exists.
+
AUTHOR
Original code by Damian Conway.
diff -ruN Class-Data-Inheritable-0.08.orig/lib/Class/Data/Inheritable.pm Class-Data-Inheritable-0.08/lib/Class/Data/Inheritable.pm
--- Class-Data-Inheritable-0.08.orig/lib/Class/Data/Inheritable.pm 2008-01-25 11:51:00.000000000 +0000
+++ Class-Data-Inheritable-0.08/lib/Class/Data/Inheritable.pm 2009-11-09 13:29:29.369687200 +0000
@@ -4,6 +4,10 @@
use vars qw($VERSION);
$VERSION = '0.08';
+if (eval { require Sub::Name }) {
+ Sub::Name->import;
+}
+
sub mk_classdata {
my ($declaredclass, $attribute, $data) = @_;
@@ -22,9 +26,18 @@
return $data;
};
- my $alias = "_${attribute}_accessor";
- *{$declaredclass.'::'.$attribute} = $accessor;
- *{$declaredclass.'::'.$alias} = $accessor;
+ my $name = "${declaredclass}::$attribute";
+ my $subnamed = 0;
+ unless (defined &{$name}) {
+ subname($name, $accessor) if defined &subname;
+ $subnamed = 1;
+ *{$name} = $accessor;
+ }
+ my $alias = "${declaredclass}::_${attribute}_accessor";
+ unless (defined &{$alias}) {
+ subname($alias, $accessor) if defined &subname and not $subnamed;
+ *{$alias} = $accessor;
+ }
}
1;
@@ -123,6 +136,9 @@
$self->_Suitcase_accessor(@_);
}
+The accessor and its alias will each not be created if a subroutine of
+the same name already exists.
+
=head1 AUTHOR
Original code by Damian Conway.
diff -ruN Class-Data-Inheritable-0.08.orig/t/Inheritable.t Class-Data-Inheritable-0.08/t/Inheritable.t
--- Class-Data-Inheritable-0.08.orig/t/Inheritable.t 2005-09-24 14:52:16.000000000 +0100
+++ Class-Data-Inheritable-0.08/t/Inheritable.t 2009-11-09 12:44:45.946263400 +0000
@@ -1,10 +1,13 @@
use strict;
-use Test::More tests => 15;
+use Test::More tests => 17;
package Ray;
use base qw(Class::Data::Inheritable);
Ray->mk_classdata('Ubu');
Ray->mk_classdata(DataFile => '/etc/stuff/data');
+Ray->mk_classdata(foo => 1);
+sub foo { return 2 }
+sub _foo_accessor { return 3 }
package Gun;
use base qw(Ray);
@@ -44,3 +47,7 @@
"Can't create classdata for an object";
is $obj->DataFile, "/tmp/stuff", "But objects can access the data";
+
+# Existing subroutines should not be overwritten
+is +Ray->foo, '2', "Existing name is not ovewrwritten";
+is +Ray->_foo_accessor, '3', "Existing alias is not ovewrwritten";