| Subject: | [PATCH] Setting data on a sub-class object undefs the sub-class translucent default value |
Setting data on a sub-class object undefs the sub-class's translucent
default value. The following program demonstrates the problem:
- test.pl -
use Class::Data::Inheritable::Translucent;
package MyClass;
use base qw(Class::Data::Inheritable::Translucent);
MyClass->mk_translucent(attr => 'foo');
sub new { return bless {}, shift }
package MySubClass;
use base qw(MyClass);
package main;
my $default = MySubClass->attr();
printf "Default='%s'\n", defined $default ? $default : '<undef>';
my $obj = MySubClass->new();
# Overriding the default on a sub-class object clobbers its default!
$obj->attr('bar');
$default = MySubClass->attr();
printf "Default now='%s'\n", defined $default ? $default : '<undef>';
__END__
That program prints out:
Default='foo'
Default now='<undef>'
but it ought to print out:
Default='foo'
Default now='foo'
The output is as expected if the line
$obj->attr('bar');
is deleted, i.e. it is the setting of the data on the sub-class object
that causes this ill effect.
The problem is the following two lines in the module:
return $wantclass->mk_translucent($attribute)->(@_)
if @_>1 && $wantclass ne $declaredclass;
That idiom is copied from Class::Data::Inheritable, where it works fine,
but it doesn't work here. The trouble is that the mk_translucent() call
in there installs an override for $attribute into $wantclass but doesn't
pass in the third argument--the translucent default value! The default
value is therefore taken to be 'undef'. The ->(@_) bit on the end then
sets the value correctly on the sub-class object, the damage has already
been to the sub-class default value.
(In Class::Data::Inheritable, they get away with it because they are
only dealing with class data. An override is installed for the sub-class
with an initial value of 'undef' as here, and then the ->(@_) bit
immediately sets that initial 'undef' value to what it ought to be *for
the sub-class*--not just for an object, because the method doesn't
operate on object attributes in that case.)
The attached patch fixes the bug by ensuring that the parent class's
current default value gets set as the sub-class's default value when
installing an override into the sub-class.
Of course, it still leaves a different undesirable behaviour, which
could be seen as another bug, in that simply installing an override for
a sub-class *object* attribute value causes that sub-class's default
value to be overridden itself. You might have expected the sub-class to
continue *inheriting* the parent class's original default value, rather
than now using a *copy* of its then-current value. (It should only
acquire its own separate copy of the default value if the attribute is
overridden on the sub-class itself, rather than on an instance of the
sub-class.) An example might be clearer: You might have expected this:
- test2.pl -
use Class::Data::Inheritable::Translucent;
package MyClass;
use base qw(Class::Data::Inheritable::Translucent);
MyClass->mk_translucent(attr => 'foo');
sub new { return bless {}, shift }
package MySubClass;
use base qw(MyClass);
package main;
my $obj = MySubClass->new();
# Overriding the default on an object makes the sub-class copy
# the current parent class default!
$obj->attr('bar');
MyClass->attr('baz');
$default = MyClass->attr();
printf "Class default='%s'\n", defined $default ? $default : '<undef>';
$default = MySubClass->attr();
printf "Sub-class default='%s'\n", defined $default ? $default : '<undef>';
__END__
to print this:
Class default='baz'
Sub-class default='baz'
rather than this:
Class default='baz'
Sub-class default='foo'
(Without the attached patch, of course, it prints:
Class default='baz'
Sub-class default='<undef>'
which is even worse.)
Unfortunately, I don't currently have a solution to the second problem,
but I think the first problem would at least be worth fixing.
| Subject: | override.patch |
diff -ruN Class-Data-Inheritable-Translucent-0.01/lib/Class/Data/Inheritable/Translucent.pm Class-Data-Inheritable-Translucent-0.01.orig/lib/Class/Data/Inheritable/Translucent.pm
--- Class-Data-Inheritable-Translucent-0.01/lib/Class/Data/Inheritable/Translucent.pm 2009-11-04 08:35:31.042194900 +0000
+++ Class-Data-Inheritable-Translucent-0.01.orig/lib/Class/Data/Inheritable/Translucent.pm 2005-12-15 20:53:06.000000000 +0000
@@ -60,7 +60,7 @@
my $obj = ref($_[0]) ? $_[0] : undef;
my $wantclass = ref($_[0]) || $_[0];
- return $wantclass->mk_translucent($attribute, $data)->(@_)
+ return $wantclass->mk_translucent($attribute)->(@_)
if @_>1 && $wantclass ne $declaredclass;
if ($obj) {