Skip Menu |

This queue is for tickets about the Sub-Name CPAN distribution.

Report information
The Basics
Id: 42725
Status: resolved
Priority: 0/
Queue: Sub-Name

People
Owner: Nobody in particular
Requestors: kentfredric [...] gmail.com
Cc:
AdminCc:

Bug Information
Severity: Unimportant
Broken in: 0.04
Fixed in: (no value)



Subject: named subs containing references to @_ $_ or %_ are not Deparsable
I recently discovered an interesting little problem where subname( $anyname , sub { @_ } ); creates sub, that when deparsed, produces an Assertion Error. died: Assertion !((((_svi)->sv_flags & (0x00004000|0x00008000)) == 0x00008000) && (((svtype)((_svi)->sv_flags & 0xff)) == SVt_PVGV || ((svtype)((_svi)->sv_flags & 0xff)) == SVt_PVLV)) failed: file "B.c", line 3896 at /usr/lib/perl5/5.10.0/x86_64-linux/B/Deparse.pm line 1292 The functions still *work* normally, they just confuse Deparse a bit. Attached is a series of tests that replicate this behaviour ( At least on my $arch ) Its set up with TODO: { and todo_skipping by default , for the sake of convenience. Thanks, Kent.
Subject: SubName.t
#!/usr/bin/perl # # Checks are skipped by default # set ENV{CHECK_DEPARSE} to make them into TODO # use strict; use warnings; use Sub::Name; use B::Deparse; use Test::More; use Test::Exception; our (@tests); sub build_test { my ( $name, $code ) = @_; push @tests, { name => $name, code => $code }; } build_test default_double_ref_array => sub { return \\@_; }; # fail build_test default_array_ref => sub { return \@_; }; # fail build_test default_array => sub { return @_; }; # fail build_test const_scalar => sub { return 1; }; # win build_test default_scalar => sub { return $_; }; # fail build_test assign_const_scalar => sub { my ($self) = 1; return $self }; # win build_test default_hash => sub { return %_ }; # fail build_test default_array_item => sub { return $_[0] }; # fail my $ntests = ( $#tests + 1 ) * 2; plan tests => $ntests; TODO: { local $TODO = "NonCritical Deparse Annoyances"; todo_skip 'CHECK_DEPARSE is undef', $ntests if !exists $ENV{CHECK_DEPARSE}; for (@tests) { can_deparse($_); } # These tests are just a failsafe to prove that its not dying because the code in the sub is bogus for (@tests) { can_run($_); } } # # This Does ALL the failing # sub generate_mop { my $test = shift; return Sub::Name::subname( 'main::fake_' . $test->{name}, $test->{code} ); } # # Is Deparsable # sub can_deparse { my $test = shift; lives_ok( sub { B::Deparse->new()->coderef2text( generate_mop($test) ); }, $test->{name} . " is deparsable" ); } # # Is Executable # sub can_run { my $test = shift; ok( defined generate_mop($test)->(qw( 1 2 3 4 5)), $test->{name} . " returns a value" ); }
Subject: [PATCH]named subs containing references to @_ $_ or %_ are not Deparsable
Hello, Matthijs van Duin. I have fixed this bug (RT #42725), and added a tiny test for it. In addition, I have improved some points: setting correct flags to cv (SvRMAGICAL_on and CvANON_off), using XPUSHs() instead of PUSHs(), defining PERL_NO_GET_CONTEXT (useful with ithreads), and using XSLoader instead of DynaLoader. I have attached these changes into single patch file, but there are commit logs on github: http://github.com/gfx/Perl-Sub-Name/tree/master Could you please review my change? Regards, -- Goro Fuji (gfx) GFUJI at CPAN.org
diff --git a/Name.xs b/Name.xs index b32411b..7422923 100644 --- a/Name.xs +++ b/Name.xs @@ -2,7 +2,7 @@ * This program is free software; you can redistribute it and/or modify * it under the same terms as Perl itself. */ - +#define PERL_NO_GET_CONTEXT #include "EXTERN.h" #include "perl.h" #include "XSUB.h" @@ -64,14 +64,7 @@ subname(name, sub) } gv = (GV *) newSV(0); gv_init(gv, stash, name, s - name, TRUE); -#ifndef USE_5005THREADS - if (CvPADLIST(cv)) { - /* cheap way to refcount the gv */ - av_store((AV *) AvARRAY(CvPADLIST(cv))[0], 0, (SV *) gv); - } else -#endif { - /* expensive way to refcount the gv */ MAGIC *mg = SvMAGIC(cv); while (mg && mg->mg_virtual != &subname_vtbl) mg = mg->mg_moremagic; @@ -87,5 +80,7 @@ subname(name, sub) mg->mg_flags |= MGf_REFCOUNTED; mg->mg_obj = (SV *) gv; } + SvRMAGICAL_on(cv); + CvANON_off(cv); CvGV(cv) = gv; - PUSHs(sub); + XPUSHs(sub); diff --git a/lib/Sub/Name.pm b/lib/Sub/Name.pm index cae03fe..1c5ab10 100644 --- a/lib/Sub/Name.pm +++ b/lib/Sub/Name.pm @@ -47,11 +47,11 @@ use warnings; our $VERSION = '0.04'; use base 'Exporter'; -use base 'DynaLoader'; our @EXPORT = qw(subname); our @EXPORT_OK = @EXPORT; -bootstrap Sub::Name $VERSION; +use XSLoader; +XSLoader::load(__PACKAGE__, $VERSION); 1; diff --git a/t/RT42725_deparse.t b/t/RT42725_deparse.t new file mode 100644 index 0000000..d43c8f9 --- /dev/null +++ b/t/RT42725_deparse.t @@ -0,0 +1,15 @@ +#!perl -w +use strict; +use Test::More tests => 2; + +use Sub::Name; + +use B::Deparse; + +my $source = eval{ + B::Deparse->new->coderef2text(subname foo => sub{ @_ }); +}; + +is $@, ''; + +like $source, qr/\@\_/;