[PATCH] Class::Struct calls UNIVERSAL::isa as a function #15891
Comments
From jkahrman@mathworks.comThis is a bug report for perl from jkahrman@mathworks.com, Class::Struct calls UNIVERSAL::isa as a function to check class membership when This is painful when attempting to unit test classes whose data members have Flags: Site configuration information for perl 5.20.2: Configured by Debian Project at Mon Jan 11 23:24:04 UTC 2016. Summary of my perl5 (revision 5 version 20 subversion 2) configuration: Platform: Locally applied patches: @INC for perl 5.20.2: Environment for perl 5.20.2: |
From jkahrman@mathworks.comisaAsMethod.patch--- perl5.20.2.orig/lib/Class/Struct.pm 2016-11-03 00:16:14.000000000 -0400
+++ lib/Class/Struct.pm 2016-11-03 00:16:14.000000000 -0400
@@ -166,7 +166,7 @@
$out .= " if (defined(\$init{'$name'})) {\n";
$out .= " if (ref \$init{'$name'} eq 'HASH')\n";
$out .= " { \$r->$name( $type->new(\%{\$init{'$name'}}) ) } $cmt\n";
- $out .= " elsif (UNIVERSAL::isa(\$init{'$name'}, '$type'))\n";
+ $out .= " elsif (eval{\$init{'$name'}->isa('$type')})\n";
$out .= " { \$r->$name( \$init{'$name'} ) } $cmt\n";
$out .= " else { croak 'Initializer for $name must be hash or $type reference' }\n";
$out .= " }\n";
@@ -217,7 +217,7 @@
$sel = "->{\$i}";
}
elsif( defined $classes{$name} ){
- $out .= " croak '$name argument is wrong class' if \@_ && ! UNIVERSAL::isa(\$_[0], '$classes{$name}');\n";
+ $out .= " croak '$name argument is wrong class' if \@_ && ! eval{\$_[0]->isa('$classes{$name}')};\n";
}
$out .= " croak 'Too many args to $name' if \@_ > 1;\n";
$out .= " \@_ ? ($pre\$r->$elem$sel = shift$pst) : $pre\$r->$elem$sel$pst;\n";
--- perl5.20.2.orig/lib/Class/Struct.t 2016-11-03 00:16:14.000000000 -0400
+++ lib/Class/Struct.t 2016-11-03 00:16:14.000000000 -0400
@@ -15,6 +15,12 @@
package RecClass;
sub new { bless {}, shift }
+# test overriden isa (Test::MockObject->new->set_isa)
+package MockAClass;
+sub new { bless {}, shift }
+sub meth { 47 }
+sub isa { $_[1] eq 'aClass'}
+
#
# The first of our Class::Struct based objects.
#
@@ -113,7 +119,30 @@
isa_ok $obj->c, 'aClass';
is $obj->c->meth(), 42;
+$obj = MyOther->new( c => 'aClass' );
+isa_ok $obj->c, 'aClass', q{package name 'aClass'};
+is $obj->c->meth(), 42;
+$obj = MyOther->new;
+$obj->c('aClass');
+isa_ok $obj->c, 'aClass', q{package name 'aClass'};
+is $obj->c->meth(), 42;
+
+$obj = MyOther->new( c => MockAClass->new );
+isa_ok $obj->c, 'aClass', 'mock';
+is $obj->c->meth(), 47;
+
+$obj->c(MockAClass->new);
+is $obj->c->meth(), 47;
+
+$obj = MyOther->new( c => 'MockAClass' );
+isa_ok $obj->c, 'aClass', q{package name 'MockAClass'};
+is $obj->c->meth(), 47;
+
+$obj = MyOther->new;
+$obj->c('MockAClass');
+isa_ok $obj->c, 'aClass', q{package name 'MockAClass'};
+is $obj->c->meth(), 47;
my $obk = SomeClass->new();
$obk->SomeElem(123);
|
From @jkeenanOn Fri, 24 Feb 2017 21:44:04 GMT, jkahrman@mathworks.com wrote:
Thanks for the patch. However, I see that you've drawn it against perl-5.20.2, which is no longer supported. Would it be possible to re-draw the patch against perl 5 blead, e.g., with git format-patch? Since we're now in a pre-5.26.0-release code freeze, I'm going to mark this ticket to be reviewed for perl-5.27.1. Thank you very much. -- |
|
The RT System itself - Status changed from 'new' to 'open' |
From @tonycozOn Sun, 26 Feb 2017 13:09:56 -0800, jkeenan wrote:
As you say it should be delayed until 5.27. The patch itself, once the format is fixed (the before and after paths have different numbers of path prefixes to remove) applies cleanly to blead, so a format-patch patch will just add the author and comment (which is still useful). Tony |
From @jkeenanOn Mon, 27 Feb 2017 00:32:34 GMT, tonyc wrote:
Tony, I'm not sure how you got this to apply to blead (I tried 'git apply', without success), but if you'd like to take a go at it, please do so. Thank you very much. -- |
From jkahrman@mathworks.comI've updated the paths in the patch to make git happy. 'git apply' against blead appears to work. There haven't been any modifications to these files since 2013, so there shouldn't be any merge issues. On Thu, 01 Jun 2017 08:31:50 -0700, jkeenan wrote:
|
From jkahrman@mathworks.comisaAsMethod.patch--- a/lib/Class/Struct.pm 2016-11-03 00:16:14.000000000 -0400
+++ b/lib/Class/Struct.pm 2016-11-03 00:16:14.000000000 -0400
@@ -166,7 +166,7 @@
$out .= " if (defined(\$init{'$name'})) {\n";
$out .= " if (ref \$init{'$name'} eq 'HASH')\n";
$out .= " { \$r->$name( $type->new(\%{\$init{'$name'}}) ) } $cmt\n";
- $out .= " elsif (UNIVERSAL::isa(\$init{'$name'}, '$type'))\n";
+ $out .= " elsif (eval{\$init{'$name'}->isa('$type')})\n";
$out .= " { \$r->$name( \$init{'$name'} ) } $cmt\n";
$out .= " else { croak 'Initializer for $name must be hash or $type reference' }\n";
$out .= " }\n";
@@ -217,7 +217,7 @@
$sel = "->{\$i}";
}
elsif( defined $classes{$name} ){
- $out .= " croak '$name argument is wrong class' if \@_ && ! UNIVERSAL::isa(\$_[0], '$classes{$name}');\n";
+ $out .= " croak '$name argument is wrong class' if \@_ && ! eval{\$_[0]->isa('$classes{$name}')};\n";
}
$out .= " croak 'Too many args to $name' if \@_ > 1;\n";
$out .= " \@_ ? ($pre\$r->$elem$sel = shift$pst) : $pre\$r->$elem$sel$pst;\n";
--- a/lib/Class/Struct.t 2016-11-03 00:16:14.000000000 -0400
+++ b/lib/Class/Struct.t 2016-11-03 00:16:14.000000000 -0400
@@ -15,6 +15,12 @@
package RecClass;
sub new { bless {}, shift }
+# test overriden isa (Test::MockObject->new->set_isa)
+package MockAClass;
+sub new { bless {}, shift }
+sub meth { 47 }
+sub isa { $_[1] eq 'aClass'}
+
#
# The first of our Class::Struct based objects.
#
@@ -113,7 +119,30 @@
isa_ok $obj->c, 'aClass';
is $obj->c->meth(), 42;
+$obj = MyOther->new( c => 'aClass' );
+isa_ok $obj->c, 'aClass', q{package name 'aClass'};
+is $obj->c->meth(), 42;
+$obj = MyOther->new;
+$obj->c('aClass');
+isa_ok $obj->c, 'aClass', q{package name 'aClass'};
+is $obj->c->meth(), 42;
+
+$obj = MyOther->new( c => MockAClass->new );
+isa_ok $obj->c, 'aClass', 'mock';
+is $obj->c->meth(), 47;
+
+$obj->c(MockAClass->new);
+is $obj->c->meth(), 47;
+
+$obj = MyOther->new( c => 'MockAClass' );
+isa_ok $obj->c, 'aClass', q{package name 'MockAClass'};
+is $obj->c->meth(), 47;
+
+$obj = MyOther->new;
+$obj->c('MockAClass');
+isa_ok $obj->c, 'aClass', q{package name 'MockAClass'};
+is $obj->c->meth(), 47;
my $obk = SomeClass->new();
$obk->SomeElem(123);
|
From @jkeenanOn Tue, 31 Oct 2017 23:21:28 GMT, jkahrman@mathworks.com wrote:
The patch applies cleanly with 'git apply'. $VERSION in lib/Class/Struct.pm will have to be incremented to keep t/porting/cmp_version.t happy; otherwise make test_harness passes. Since TonyC has been following this issue, I'll defer to him on final application. Thank you very much. |
Migrated from rt.perl.org#130854 (status was 'open')
Searchable as RT130854$
The text was updated successfully, but these errors were encountered: