lexical subs don't seem to honor prototypes

p5pRT commented 11 years ago

Migrated from rt.perl.org#116735 (status was 'resolved')

Searchable as RT116735$

p5pRT commented 11 years ago

From PeterCMartini@GMail.com

Created by petercmartini@gmail.com

lexical subs don't seem to honor prototypes:

perl5.17.9 -Mfeature=lexical_subs -e 'my sub a($$){} a 1;'

Get rid of the 'my'\, and that dies.

Perl Info

``` Flags: category=core severity=low Site configuration information for perl 5.17.9: Configured by pmartini at Wed Feb 6 02:51:49 EST 2013. Summary of my perl5 (revision 5 version 17 subversion 9) configuration: Derived from: 52a2a812ca95071d6e5d921cf74061d912278729 Platform: osname=linux, osvers=3.2.0-32-generic, archname=i686-linux-thread-multi uname='linux pmlinlaptop 3.2.0-32-generic #51-ubuntu smp wed sep 26 21:32:50 utc 2012 i686 i686 i386 gnulinux ' config_args='-Dusedevel -DDEBUGGING -Dusethreads -des' hint=recommended, useposix=true, d_sigaction=define useithreads=define, usemultiplicity=define useperlio=define, d_sfio=undef, uselargefiles=define, usesocks=undef use64bitint=undef, use64bitall=undef, uselongdouble=undef usemymalloc=n, bincompat5005=undef Compiler: cc='cc', ccflags ='-D_REENTRANT -D_GNU_SOURCE -DDEBUGGING -fno-strict-aliasing -pipe -fstack-protector -I/usr/local/include -D_LARGEFILE_SOURCE -D_FILE_OFFSET_BITS=64', optimize='-O2 -g', cppflags='-D_REENTRANT -D_GNU_SOURCE -DDEBUGGING -fno-strict-aliasing -pipe -fstack-protector -I/usr/local/include' ccversion='', gccversion='4.6.3', gccosandvers='' intsize=4, longsize=4, ptrsize=4, doublesize=8, byteorder=1234 d_longlong=define, longlongsize=8, d_longdbl=define, longdblsize=12 ivtype='long', ivsize=4, nvtype='double', nvsize=8, Off_t='off_t', lseeksize=8 alignbytes=4, prototype=define Linker and Libraries: ld='cc', ldflags =' -fstack-protector -L/usr/local/lib' libpth=/usr/local/lib /lib/i386-linux-gnu /lib/../lib /usr/lib/i386-linux-gnu /usr/lib/../lib /lib /usr/lib libs=-lnsl -ldl -lm -lcrypt -lutil -lpthread -lc perllibs=-lnsl -ldl -lm -lcrypt -lutil -lpthread -lc libc=, so=so, useshrplib=false, libperl=libperl.a gnulibc_version='2.15' Dynamic Linking: dlsrc=dl_dlopen.xs, dlext=so, d_dlsymun=undef, ccdlflags='-Wl,-E' cccdlflags='-fPIC', lddlflags='-shared -O2 -g -L/usr/local/lib -fstack-protector' Locally applied patches: @INC for perl 5.17.9: /usr/local/lib/perl5/site_perl/5.17.9/i686-linux-thread-multi /usr/local/lib/perl5/site_perl/5.17.9 /usr/local/lib/perl5/5.17.9/i686-linux-thread-multi /usr/local/lib/perl5/5.17.9 /usr/local/lib/perl5/site_perl . Environment for perl 5.17.9: HOME=/home/pmartini LANG=en_US.UTF-8 LANGUAGE (unset) LD_LIBRARY_PATH (unset) LOGDIR (unset) PATH=/usr/lib/lightdm/lightdm:/usr/local/sbin:/usr/local/bin:/usr/sbin:/usr/bin:/sbin:/bin:/usr/games PERL_BADLANG (unset) SHELL=/bin/bash ```

p5pRT commented 11 years ago

From PeterCMartini@GMail.com

So\, this is because prototype handling operates on an rv pointing to a cv\, and padcv is left out (since there's no rv pointing to it).

Fixing that gets to this little bit of ugliness\, as explained in op.c:

if (!namegv) { /* expletive! */ /* XXX The call checker API is public. And it guarantees that a GV will be provided with the right name. So we have to create a GV. But it is still not correct\, as its stringification will include the package. What we really need is a new call checker API that accepts a GV or string (or GV or CV). */

I'm not sure what the best way forward is here.

p5pRT commented 11 years ago

From [Unknown Contact. See original ticket]

So\, this is because prototype handling operates on an rv pointing to a cv\, and padcv is left out (since there's no rv pointing to it).

Fixing that gets to this little bit of ugliness\, as explained in op.c:

if (!namegv) { /* expletive! */ /* XXX The call checker API is public. And it guarantees that a GV will be provided with the right name. So we have to create a GV. But it is still not correct\, as its stringification will include the package. What we really need is a new call checker API that accepts a GV or string (or GV or CV). */

I'm not sure what the best way forward is here.

p5pRT commented 11 years ago

PeterCMartini@GMail.com - Status changed from 'new' to 'open'

p5pRT commented 11 years ago

From PeterCMartini@GMail.com

The tests for lexical subs (t/cmd/lexsub.t) includes this:

package main; { sub me ($); is prototype eval{\&me}\, '$'\, 'my sub with proto'; is prototype "me"\, undef\, 'prototype "..." ignores my subs'; }

That last test seems like a bug rather than a feature\, and is part of the reason prototypes don't work with lexical variables - prototypes are only found if they're looked up via rv2cv\, rather than via the new padcv op.

If we can agree that that test should also return '$'\, then I can submit a patch (for review) that gets prototypes working for lexical subs.

It's a rather involved patch...

p5pRT commented 11 years ago

From [Unknown Contact. See original ticket]

The tests for lexical subs (t/cmd/lexsub.t) includes this:

package main; { sub me ($); is prototype eval{\&me}\, '$'\, 'my sub with proto'; is prototype "me"\, undef\, 'prototype "..." ignores my subs'; }

That last test seems like a bug rather than a feature\, and is part of the reason prototypes don't work with lexical variables - prototypes are only found if they're looked up via rv2cv\, rather than via the new padcv op.

If we can agree that that test should also return '$'\, then I can submit a patch (for review) that gets prototypes working for lexical subs.

It's a rather involved patch...

p5pRT commented 11 years ago

From @rgarcia

On 17 February 2013 06:36\, Peter Martini via RT \perlbug\-comment@perl\.org wrote:

The tests for lexical subs (t/cmd/lexsub.t) includes this:

package main; { sub me ($); is prototype eval{\&me}\, '$'\, 'my sub with proto'; is prototype "me"\, undef\, 'prototype "..." ignores my subs'; }

That last test seems like a bug rather than a feature\, and is part of the reason prototypes don't work with lexical variables - prototypes are only found if they're looked up via rv2cv\, rather than via the new padcv op.

If we can agree that that test should also return '$'\, then I can submit a patch (for review) that gets prototypes working for lexical subs.

It's a rather involved patch...

In any event\, I think that either 5.18 should have lexical-sub prototypes working\, or warning (or dying?) just to make sure no-one starts writing code that assumes the current behaviour is correct...

p5pRT commented 11 years ago

From PeterCMartini@GMail.com

On Mon\, Feb 18\, 2013 at 3:47 AM\, Rafael Garcia-Suarez \rgs@consttype\.org wrote:

On 17 February 2013 06:36\, Peter Martini via RT \perlbug\-comment@perl\.org wrote:

The tests for lexical subs (t/cmd/lexsub.t) includes this:

package main; { sub me ($); is prototype eval{\&me}\, '$'\, 'my sub with proto'; is prototype "me"\, undef\, 'prototype "..." ignores my subs'; }

That last test seems like a bug rather than a feature\, and is part of the reason prototypes don't work with lexical variables - prototypes are only found if they're looked up via rv2cv\, rather than via the new padcv op.

If we can agree that that test should also return '$'\, then I can submit a patch (for review) that gets prototypes working for lexical subs.

It's a rather involved patch...

In any event\, I think that either 5.18 should have lexical-sub prototypes working\, or warning (or dying?) just to make sure no-one starts writing code that assumes the current behaviour is correct...

We're in good shape on that point:

perl5.17.9 -E 'my sub foo {say @_} foo 1;' Experimental "my" subs not enabled at -e line 1.

perl5.17.9 -Mfeature=lexical_subs -E 'my sub foo {say @_} foo 1;' The lexical_subs feature is experimental at -e line 1. 1

It warns no matter what\, but doesn't even execute unless you specifically enable it.

p5pRT commented 11 years ago

From PeterCMartini@GMail.com

On Tue Feb 12 20:53:03 2013\, pcm wrote:

This is a bug report for perl from petercmartini@gmail.com\, generated with the help of perlbug 1.39 running under perl 5.17.9.

----------------------------------------------------------------- [Please describe your issue here]

lexical subs don't seem to honor prototypes:

perl5.17.9 -Mfeature=lexical_subs -e 'my sub a($$){} a 1;'

Get rid of the 'my'\, and that dies.

[Please do not change anything below this line] ----------------------------------------------------------------- --- Flags: category=core severity=low --- Site configuration information for perl 5.17.9:

Configured by pmartini at Wed Feb 6 02:51:49 EST 2013.

Summary of my perl5 (revision 5 version 17 subversion 9) configuration: Derived from: 52a2a812ca95071d6e5d921cf74061d912278729 Platform: osname=linux\, osvers=3.2.0-32-generic\, archname=i686-linux-thread- multi uname='linux pmlinlaptop 3.2.0-32-generic #51-ubuntu smp wed sep 26 21:32:50 utc 2012 i686 i686 i386 gnulinux ' config_args='-Dusedevel -DDEBUGGING -Dusethreads -des' hint=recommended\, useposix=true\, d_sigaction=define useithreads=define\, usemultiplicity=define useperlio=define\, d_sfio=undef\, uselargefiles=define\, usesocks=undef use64bitint=undef\, use64bitall=undef\, uselongdouble=undef usemymalloc=n\, bincompat5005=undef Compiler: cc='cc'\, ccflags ='-D_REENTRANT -D_GNU_SOURCE -DDEBUGGING -fno-strict-aliasing -pipe -fstack-protector -I/usr/local/include -D_LARGEFILE_SOURCE -D_FILE_OFFSET_BITS=64'\, optimize='-O2 -g'\, cppflags='-D_REENTRANT -D_GNU_SOURCE -DDEBUGGING -fno-strict-aliasing -pipe -fstack-protector -I/usr/local/include' ccversion=''\, gccversion='4.6.3'\, gccosandvers='' intsize=4\, longsize=4\, ptrsize=4\, doublesize=8\, byteorder=1234 d_longlong=define\, longlongsize=8\, d_longdbl=define\, longdblsize=12 ivtype='long'\, ivsize=4\, nvtype='double'\, nvsize=8\, Off_t='off_t'\, lseeksize=8 alignbytes=4\, prototype=define Linker and Libraries: ld='cc'\, ldflags =' -fstack-protector -L/usr/local/lib' libpth=/usr/local/lib /lib/i386-linux-gnu /lib/../lib /usr/lib/i386-linux-gnu /usr/lib/../lib /lib /usr/lib libs=-lnsl -ldl -lm -lcrypt -lutil -lpthread -lc perllibs=-lnsl -ldl -lm -lcrypt -lutil -lpthread -lc libc=\, so=so\, useshrplib=false\, libperl=libperl.a gnulibc_version='2.15' Dynamic Linking: dlsrc=dl_dlopen.xs\, dlext=so\, d_dlsymun=undef\, ccdlflags='-Wl\,-E' cccdlflags='-fPIC'\, lddlflags='-shared -O2 -g -L/usr/local/lib -fstack-protector'

Locally applied patches:

--- @INC for perl 5.17.9: /usr/local/lib/perl5/site_perl/5.17.9/i686-linux-thread-multi /usr/local/lib/perl5/site_perl/5.17.9 /usr/local/lib/perl5/5.17.9/i686-linux-thread-multi /usr/local/lib/perl5/5.17.9 /usr/local/lib/perl5/site_perl .

--- Environment for perl 5.17.9: HOME=/home/pmartini LANG=en_US.UTF-8 LANGUAGE (unset) LD_LIBRARY_PATH (unset) LOGDIR (unset)

PATH=/usr/lib/lightdm/lightdm:/usr/local/sbin:/usr/local/bin:/usr/sbin:/ usr/bin:/sbin:/bin:/usr/games PERL_BADLANG (unset) SHELL=/bin/bash

Further testing:

perl5.17.9 -Mfeature=lexical_subs -e 'my sub a($$){} a 1;'

Does not check prototypes.

perl5.17.9 -Mfeature=lexical_subs -e 'my sub a($$){} a(1);'

*Does* check prototypes.

The difference is the second one generates an rv2cv pointing to the padcv\, while the first one uses the padcv directly.

I'd been playing with ways to fix this\, and checked in my work-in- progress (as a single large-ish commit) this morning: https://github.com/PeterMartini/perl/commit/lexical-proto

There are two components\, which are separable:

1. Change ck_subr to grab the CV directly from padcv if that's the last op\, which is the simple fix\, and I'll defer to anyone more knowledgeable on whether it's the correct fix.

2. Father C had noted that the Perl_call_checker API passes a GV*\, which no longer works\, since a lexical sub won't have a GV. The solution as of right now is a faked up GV\, which as noted is not ideal\, as it includes the current package.

I added an alternate API\, Perl_call_checker_sv and appropriate get/set functions\, so that the name could be passed be specified as an SV*. For backwards compatibility reasons\, if a custom Perl_call_checker was set\, it will use that; if a custom Perl_call_checker_sv was set\, it will use that; otherwise\, it will use the default Perl_call_checker_sv.

These both get stored in checkcall magic\, so only one can be active at a time. If the current\, GV form\, is used in a set\, and the SV form is used in a get\, the get returns a NULL pointer. In the reverse case\, where the new API is used to set an override\, and the old API is used to get it back\, the code will croak. The reason for the difference is the old API implies the call will always succeed\, so returning a NULL would be a bad idea\, while the new version is documented to return NULL to indicate that the alternate API should be used.

************

Now that I see that prototypes are actually partially honored\, applying just the first part would get us to consistency with minimal risk of side effects\, and the second part can be polished up as a nice to have.

p5pRT commented 11 years ago

From [Unknown Contact. See original ticket]

On Tue Feb 12 20:53:03 2013\, pcm wrote:

This is a bug report for perl from petercmartini@gmail.com\, generated with the help of perlbug 1.39 running under perl 5.17.9.

----------------------------------------------------------------- [Please describe your issue here]

lexical subs don't seem to honor prototypes:

perl5.17.9 -Mfeature=lexical_subs -e 'my sub a($$){} a 1;'

Get rid of the 'my'\, and that dies.

[Please do not change anything below this line] ----------------------------------------------------------------- --- Flags: category=core severity=low --- Site configuration information for perl 5.17.9:

Configured by pmartini at Wed Feb 6 02:51:49 EST 2013.

Summary of my perl5 (revision 5 version 17 subversion 9) configuration: Derived from: 52a2a812ca95071d6e5d921cf74061d912278729 Platform: osname=linux\, osvers=3.2.0-32-generic\, archname=i686-linux-thread- multi uname='linux pmlinlaptop 3.2.0-32-generic #51-ubuntu smp wed sep 26 21:32:50 utc 2012 i686 i686 i386 gnulinux ' config_args='-Dusedevel -DDEBUGGING -Dusethreads -des' hint=recommended\, useposix=true\, d_sigaction=define useithreads=define\, usemultiplicity=define useperlio=define\, d_sfio=undef\, uselargefiles=define\, usesocks=undef use64bitint=undef\, use64bitall=undef\, uselongdouble=undef usemymalloc=n\, bincompat5005=undef Compiler: cc='cc'\, ccflags ='-D_REENTRANT -D_GNU_SOURCE -DDEBUGGING -fno-strict-aliasing -pipe -fstack-protector -I/usr/local/include -D_LARGEFILE_SOURCE -D_FILE_OFFSET_BITS=64'\, optimize='-O2 -g'\, cppflags='-D_REENTRANT -D_GNU_SOURCE -DDEBUGGING -fno-strict-aliasing -pipe -fstack-protector -I/usr/local/include' ccversion=''\, gccversion='4.6.3'\, gccosandvers='' intsize=4\, longsize=4\, ptrsize=4\, doublesize=8\, byteorder=1234 d_longlong=define\, longlongsize=8\, d_longdbl=define\, longdblsize=12 ivtype='long'\, ivsize=4\, nvtype='double'\, nvsize=8\, Off_t='off_t'\, lseeksize=8 alignbytes=4\, prototype=define Linker and Libraries: ld='cc'\, ldflags =' -fstack-protector -L/usr/local/lib' libpth=/usr/local/lib /lib/i386-linux-gnu /lib/../lib /usr/lib/i386-linux-gnu /usr/lib/../lib /lib /usr/lib libs=-lnsl -ldl -lm -lcrypt -lutil -lpthread -lc perllibs=-lnsl -ldl -lm -lcrypt -lutil -lpthread -lc libc=\, so=so\, useshrplib=false\, libperl=libperl.a gnulibc_version='2.15' Dynamic Linking: dlsrc=dl_dlopen.xs\, dlext=so\, d_dlsymun=undef\, ccdlflags='-Wl\,-E' cccdlflags='-fPIC'\, lddlflags='-shared -O2 -g -L/usr/local/lib -fstack-protector'

Locally applied patches:

--- @INC for perl 5.17.9: /usr/local/lib/perl5/site_perl/5.17.9/i686-linux-thread-multi /usr/local/lib/perl5/site_perl/5.17.9 /usr/local/lib/perl5/5.17.9/i686-linux-thread-multi /usr/local/lib/perl5/5.17.9 /usr/local/lib/perl5/site_perl .

--- Environment for perl 5.17.9: HOME=/home/pmartini LANG=en_US.UTF-8 LANGUAGE (unset) LD_LIBRARY_PATH (unset) LOGDIR (unset)

PATH=/usr/lib/lightdm/lightdm:/usr/local/sbin:/usr/local/bin:/usr/sbin:/ usr/bin:/sbin:/bin:/usr/games PERL_BADLANG (unset) SHELL=/bin/bash

Further testing:

perl5.17.9 -Mfeature=lexical_subs -e 'my sub a($$){} a 1;'

Does not check prototypes.

perl5.17.9 -Mfeature=lexical_subs -e 'my sub a($$){} a(1);'

*Does* check prototypes.

The difference is the second one generates an rv2cv pointing to the padcv\, while the first one uses the padcv directly.

I'd been playing with ways to fix this\, and checked in my work-in- progress (as a single large-ish commit) this morning: https://github.com/PeterMartini/perl/commit/lexical-proto

There are two components\, which are separable:

1. Change ck_subr to grab the CV directly from padcv if that's the last op\, which is the simple fix\, and I'll defer to anyone more knowledgeable on whether it's the correct fix.

2. Father C had noted that the Perl_call_checker API passes a GV*\, which no longer works\, since a lexical sub won't have a GV. The solution as of right now is a faked up GV\, which as noted is not ideal\, as it includes the current package.

I added an alternate API\, Perl_call_checker_sv and appropriate get/set functions\, so that the name could be passed be specified as an SV*. For backwards compatibility reasons\, if a custom Perl_call_checker was set\, it will use that; if a custom Perl_call_checker_sv was set\, it will use that; otherwise\, it will use the default Perl_call_checker_sv.

These both get stored in checkcall magic\, so only one can be active at a time. If the current\, GV form\, is used in a set\, and the SV form is used in a get\, the get returns a NULL pointer. In the reverse case\, where the new API is used to set an override\, and the old API is used to get it back\, the code will croak. The reason for the difference is the old API implies the call will always succeed\, so returning a NULL would be a bad idea\, while the new version is documented to return NULL to indicate that the alternate API should be used.

************

Now that I see that prototypes are actually partially honored\, applying just the first part would get us to consistency with minimal risk of side effects\, and the second part can be polished up as a nice to have.

p5pRT commented 11 years ago

From PeterCMartini@GMail.com

Father C -

This change:

Inline Patch

```diff diff --git a/op.c b/op.c index c9a1b53..9c2d06a 100644 --- a/op.c +++ b/op.c @@ -8135,7 +8135,6 @@ Perl_newCVREF(pTHX_ I32 flags, OP *o) dVAR; o->op_type = OP_PADCV; o->op_ppaddr = PL_ppaddr[OP_PADCV]; - return o; } return newUNOP(OP_RV2CV, flags, scalar(o)); } ```

Seems like it should be sufficient for the fix, but it's causing assertion failures on assert(hek) in the case of a const sub:

'my sub if(){44} if;' # boom!

I haven't been able to chase down a fix for that part yet\, though.

p5pRT commented 11 years ago

From [Unknown Contact. See original ticket]

Father C -

This change:

Inline Patch

```diff diff --git a/op.c b/op.c index c9a1b53..9c2d06a 100644 --- a/op.c +++ b/op.c @@ -8135,7 +8135,6 @@ Perl_newCVREF(pTHX_ I32 flags, OP *o) dVAR; o->op_type = OP_PADCV; o->op_ppaddr = PL_ppaddr[OP_PADCV]; - return o; } return newUNOP(OP_RV2CV, flags, scalar(o)); } ```

Seems like it should be sufficient for the fix, but it's causing assertion failures on assert(hek) in the case of a const sub:

'my sub if(){44} if;' # boom!

I haven't been able to chase down a fix for that part yet\, though.

p5pRT commented 11 years ago

From @chipdude

On 2/16/2013 9:36 PM\, Peter Martini via RT wrote:

package main; { sub me ($); is prototype eval{\&me}\, '$'\, 'my sub with proto'; is prototype "me"\, undef\, 'prototype "..." ignores my subs'; }

That last test seems like a bug rather than a feature\, and is part of the reason prototypes don't work with lexical variables - prototypes are only found if they're looked up via rv2cv\, rather than via the new padcv op.

This test seems fine. After all\, compare with scalars. While $me might be a lexical\, ${"me"} never is. Why should & break this pattern?

Which isn't to say that lexical subs should ignore prototypes.

p5pRT commented 11 years ago

From PeterCMartini@GMail.com

On Tue\, Feb 19\, 2013 at 9:38 PM\, Reverend Chip \rev\.chip@gmail\.com wrote:

On 2/16/2013 9:36 PM\, Peter Martini via RT wrote:

package main; { sub me ($); is prototype eval{\&me}\, '$'\, 'my sub with proto'; is prototype "me"\, undef\, 'prototype "..." ignores my subs'; }

That last test seems like a bug rather than a feature\, and is part of the reason prototypes don't work with lexical variables - prototypes are only found if they're looked up via rv2cv\, rather than via the new padcv op.

This test seems fine. After all\, compare with scalars. While $me might be a lexical\, ${"me"} never is. Why should & break this pattern?

Ah\, that makes sense\, and proves the point that my original approach was too hackish for its own good.

Removing the early return in newCVREF certainly looks like a much saner (and smaller) fix\, but I haven't had a chance to look into why the conversion to a const sub causes so much trouble.

Which isn't to say that lexical subs should ignore prototypes.

p5pRT commented 11 years ago

From @cpansprout

On Mon Feb 18 10:55:41 2013\, pcm wrote:

On Tue Feb 12 20:53:03 2013\, pcm wrote: Further testing:

perl5.17.9 -Mfeature=lexical_subs -e 'my sub a($$){} a 1;'

Does not check prototypes.

perl5.17.9 -Mfeature=lexical_subs -e 'my sub a($$){} a(1);'

*Does* check prototypes.

The difference is the second one generates an rv2cv pointing to the padcv\, while the first one uses the padcv directly.

I'd been playing with ways to fix this\, and checked in my work-in- progress (as a single large-ish commit) this morning: https://github.com/PeterMartini/perl/commit/lexical-proto

There are two components\, which are separable:

1. Change ck_subr to grab the CV directly from padcv if that's the last op\, which is the simple fix\, and I'll defer to anyone more knowledgeable on whether it's the correct fix.

I’ve done what I think is the more correct fix\, which is to avoid generating two disparate op trees to begin with\, in commit 9a5e6f3cd84.

2. Father C had noted that the Perl_call_checker API passes a GV*\, which no longer works\, since a lexical sub won't have a GV. The solution as of right now is a faked up GV\, which as noted is not ideal\, as it includes the current package.

I added an alternate API\, Perl_call_checker_sv and appropriate get/set functions\, so that the name could be passed be specified as an SV*. For backwards compatibility reasons\, if a custom Perl_call_checker was set\, it will use that; if a custom Perl_call_checker_sv was set\, it will use that; otherwise\, it will use the default Perl_call_checker_sv.

These both get stored in checkcall magic\, so only one can be active at a time. If the current\, GV form\, is used in a set\, and the SV form is used in a get\, the get returns a NULL pointer. In the reverse case\, where the new API is used to set an override\, and the old API is used to get it back\, the code will croak. The reason for the difference is the old API implies the call will always succeed\, so returning a NULL would be a bad idea\, while the new version is documented to return NULL to indicate that the alternate API should be used.

************

Now that I see that prototypes are actually partially honored\, applying just the first part would get us to consistency with minimal risk of side effects\, and the second part can be polished up as a nice to have.

Would you be willing to do that? :-)

One thing I thought about was to create a new API function\, maybe called cv_name\, which can be passed\, a CV\, a GV\, or any stringifiable SV. It would return an SV containing the name of the sub (a new mortal for a CV or GV; the SV itself otherwise).

Whatever value is passed through the new call checker API could be passed through to cv_name when an error is reported.

--

Father Chrysostomos

p5pRT commented 11 years ago

From @cpansprout

On Tue Feb 19 07:08:56 2013\, pcm wrote:

Father C -

This change:

diff --git a/op.c b/op.c index c9a1b53..9c2d06a 100644 --- a/op.c +++ b/op.c @@ -8135\,7 +8135\,6 @@ Perl_newCVREF(pTHX_ I32 flags\, OP *o) dVAR; o->op_type = OP_PADCV; o->op_ppaddr = PL_ppaddr[OP_PADCV]; - return o; } return newUNOP(OP_RV2CV\, flags\, scalar(o)); }

Seems like it should be sufficient for the fix\, but it's causing assertion failures on assert(hek) in the case of a const sub:

'my sub if(){44} if;' # boom!

I haven't been able to chase down a fix for that part yet\, though.

That part I’ve fixed in commit 83a72a15a3.

--

Father Chrysostomos

p5pRT commented 11 years ago

From PeterCMartini@GMail.com

On Sun Jun 02 13:36:14 2013\, sprout wrote:

On Mon Feb 18 10:55:41 2013\, pcm wrote:

On Tue Feb 12 20:53:03 2013\, pcm wrote: Further testing:

perl5.17.9 -Mfeature=lexical_subs -e 'my sub a($$){} a 1;'

Does not check prototypes.

perl5.17.9 -Mfeature=lexical_subs -e 'my sub a($$){} a(1);'

*Does* check prototypes.

The difference is the second one generates an rv2cv pointing to the padcv\, while the first one uses the padcv directly.

I'd been playing with ways to fix this\, and checked in my work-in- progress (as a single large-ish commit) this morning: https://github.com/PeterMartini/perl/commit/lexical-proto

There are two components\, which are separable:

1. Change ck_subr to grab the CV directly from padcv if that's the last op\, which is the simple fix\, and I'll defer to anyone more knowledgeable on whether it's the correct fix.

I’ve done what I think is the more correct fix\, which is to avoid generating two disparate op trees to begin with\, in commit 9a5e6f3cd84.

2. Father C had noted that the Perl_call_checker API passes a GV*\, which no longer works\, since a lexical sub won't have a GV. The solution as of right now is a faked up GV\, which as noted is not ideal\, as it includes the current package.

I added an alternate API\, Perl_call_checker_sv and appropriate get/set functions\, so that the name could be passed be specified as an SV*.
For backwards compatibility reasons\, if a custom Perl_call_checker was set\, it will use that; if a custom Perl_call_checker_sv was set\, it will use that; otherwise\, it will use the default Perl_call_checker_sv.

These both get stored in checkcall magic\, so only one can be active at a time. If the current\, GV form\, is used in a set\, and the SV form is used in a get\, the get returns a NULL pointer. In the reverse case\, where the new API is used to set an override\, and the old API is used to get it back\, the code will croak. The reason for the difference is the old API implies the call will always succeed\, so returning a NULL would be a bad idea\, while the new version is documented to return NULL to indicate that the alternate API should be used.

************

Now that I see that prototypes are actually partially honored\, applying just the first part would get us to consistency with minimal risk of side effects\, and the second part can be polished up as a nice to have.

Would you be willing to do that? :-)

One thing I thought about was to create a new API function\, maybe called cv_name\, which can be passed\, a CV\, a GV\, or any stringifiable SV. It would return an SV containing the name of the sub (a new mortal for a CV or GV; the SV itself otherwise).

Whatever value is passed through the new call checker API could be passed through to cv_name when an error is reported.

If you don't beat me to it\, I'll put that on my TODO list :-)

p5pRT commented 10 years ago

From @cpansprout

On Sun Jun 02 13:36:14 2013\, sprout wrote:

On Mon Feb 18 10:55:41 2013\, pcm wrote:

I'd been playing with ways to fix this\, and checked in my work-in- progress (as a single large-ish commit) this morning: https://github.com/PeterMartini/perl/commit/lexical-proto

That URL does not work any more.

There are two components\, which are separable:

1. Change ck_subr to grab the CV directly from padcv if that's the last op\, which is the simple fix\, and I'll defer to anyone more knowledgeable on whether it's the correct fix.

I’ve done what I think is the more correct fix\, which is to avoid generating two disparate op trees to begin with\, in commit 9a5e6f3cd84.

2. Father C had noted that the Perl_call_checker API passes a GV*\, which no longer works\, since a lexical sub won't have a GV. The solution as of right now is a faked up GV\, which as noted is not ideal\, as it includes the current package.

I added an alternate API\, Perl_call_checker_sv and appropriate get/set functions\, so that the name could be passed be specified as an SV*. For backwards compatibility reasons\, if a custom Perl_call_checker was set\, it will use that; if a custom Perl_call_checker_sv was set\, it will use that; otherwise\, it will use the default Perl_call_checker_sv.

These both get stored in checkcall magic\, so only one can be active at a time. If the current\, GV form\, is used in a set\, and the SV form is used in a get\, the get returns a NULL pointer. In the reverse case\, where the new API is used to set an override\, and the old API is used to get it back\, the code will croak. The reason for the difference is the old API implies the call will always succeed\, so returning a NULL would be a bad idea\, while the new version is documented to return NULL to indicate that the alternate API should be used.

************

Now that I see that prototypes are actually partially honored\, applying just the first part would get us to consistency with minimal risk of side effects\, and the second part can be polished up as a nice to have.

Would you be willing to do that? :-)

I was about to do that (separate out part 2 from your patch and polish it up)\, but\, as noted above\, cannot access that URL.

Do you still have the patch floating around somewhere? If not\, I will just have to write it from scratch. I need it right now for the stuff I’m doing on the sprout/cvgv branch. (ck_subr reifies GVs and I need the alternate call checker API to remove the need for that.)

--

Father Chrysostomos

p5pRT commented 10 years ago

From @cpansprout

On Wed Sep 10 20:39:40 2014\, sprout wrote:

I was about to do that (separate out part 2 from your patch and polish it up)\, but\, as noted above\, cannot access that URL.

Do you still have the patch floating around somewhere? If not\, I will just have to write it from scratch. I need it right now for the stuff I’m doing on the sprout/cvgv branch. (ck_subr reifies GVs and I need the alternate call checker API to remove the need for that.)

Actually\, having a separate API that takes an SV* would require us to duplicate all the built-in call checkers.

Instead\, how about a cv_set_call_checker_flags\, and the only flag is CALL_CHECKER_REQUIRE_GV? cv_set_call_checker calls _flags with that flag.

The name thingy that gets passed to the call checker can be cast to GV *.

--

Father Chrysostomos

p5pRT commented 10 years ago

From @rjbs

* Father Chrysostomos via RT \perlbug\-followup@perl\.org [2014-09-10T23:39:41]

On Sun Jun 02 13:36:14 2013\, sprout wrote:

On Mon Feb 18 10:55:41 2013\, pcm wrote:

I'd been playing with ways to fix this\, and checked in my work-in- progress (as a single large-ish commit) this morning: https://github.com/PeterMartini/perl/commit/lexical-proto

That URL does not work any more.

(This is why\, even though it can be a pain in the butt\, we ask for patches to be sent in.)

-- rjbs

p5pRT commented 10 years ago

From PeterCMartini@GMail.com

On Wed\, Sep 10\, 2014 at 11:39 PM\, Father Chrysostomos via RT \perlbug\-followup@perl\.org wrote:

On Sun Jun 02 13:36:14 2013\, sprout wrote:

On Mon Feb 18 10:55:41 2013\, pcm wrote:

I'd been playing with ways to fix this\, and checked in my work-in- progress (as a single large-ish commit) this morning: https://github.com/PeterMartini/perl/commit/lexical-proto

That URL does not work any more.

I'm not quite sure at what point that got borked\, since my local git repo still listed it as only a remote branch on github (even though github didn't find it). So for my own sanity\, I did a local checkout and pushed it back up to github unmodified. All that said\, it's probably not useful at all :-)

p5pRT commented 10 years ago

From @cpansprout

On Thu Sep 11 22:50:24 2014\, pcm wrote:

I'm not quite sure at what point that got borked\, since my local git repo still listed it as only a remote branch on github (even though github didn't find it). So for my own sanity\, I did a local checkout and pushed it back up to github unmodified. All that said\, it's probably not useful at all :-)

Thank you anyway. Or\, rather\, thank you for not restoring it till now\, because I might not have been prompted by laziness to come up with a simpler solution otherwise. :-)

I do think it is over-engineered and that cv_set_call_checker_flags is a better solution.

BTW\, have you seen what I am doing on the sprout/cvgv branch? It is almost ready for merging\, but not quite. Maybe a few more days. In any case\, ‘sub foo{} foo() \&foo’ no longer has to create a *foo glob\, saving memory.

--

Father Chrysostomos

p5pRT commented 10 years ago

From @cpansprout

On Thu Sep 11 22:50:24 2014\, pcm wrote:

I'm not quite sure at what point that got borked\, since my local git repo still listed it as only a remote branch on github (even though github didn't find it). So for my own sanity\, I did a local checkout and pushed it back up to github unmodified. All that said\, it's probably not useful at all :-)

I’m attaching it here for future readers.

--

Father Chrysostomos

p5pRT commented 10 years ago

From @cpansprout

From 0229fcbc8e75a5545d5a26a870dbc4b44f2e81e1 Mon Sep 17 00:00:00 2001 From: Peter Martini \PeterCMartini@GMail\.com Date: Mon\, 18 Feb 2013 11:04:35 -0500 Subject: [PATCH] Changed to allow lexical subs to have prototypes

Inline Patch

```diff diff --git a/cv.h b/cv.h index 5da9a50..4dcc35f 100644 --- a/cv.h +++ b/cv.h @@ -268,6 +268,7 @@ should print 123: */ typedef OP *(*Perl_call_checker)(pTHX_ OP *, GV *, SV *); +typedef OP *(*Perl_call_checker_sv)(pTHX_ OP *, SV *, SV *); /* * Local variables: diff --git a/embed.fnc b/embed.fnc index a288c5a..ed09312 100644 --- a/embed.fnc +++ b/embed.fnc @@ -977,13 +977,26 @@ Apda |OP* |newWHILEOP |I32 flags|I32 debuggable|NULLOK LOOP* loop \ |NULLOK OP* expr|NULLOK OP* block|NULLOK OP* cont \ |I32 has_my Apd |CV* |rv2cv_op_cv |NN OP *cvop|U32 flags +#if defined(PERL_IN_OP_C) +s |CV* |padcv_op_cv |NN OP *padcvop|NULLOK SV ** namesv +#endif Apd |OP* |ck_entersub_args_list|NN OP *entersubop Apd |OP* |ck_entersub_args_proto|NN OP *entersubop|NN GV *namegv|NN SV *protosv +AMpd |OP* |ck_entersub_args_proto_sv|NN OP *entersubop|NN SV *namesv|NN SV *protosv +#if defined(PERL_IN_OP_C) +s |OP* |ck_entersub_args_proto_core|NN OP *entersubop|NN void *namev|NN SV *protosv|bool name_is_gv +#endif Apd |OP* |ck_entersub_args_proto_or_list|NN OP *entersubop|NN GV *namegv|NN SV *protosv +AMpd |OP* |ck_entersub_args_proto_or_list_sv|NN OP *entersubop|NN SV *namesv|NN SV *protosv po |OP* |ck_entersub_args_core|NN OP *entersubop|NN GV *namegv \ |NN SV *protosv Apd |void |cv_get_call_checker|NN CV *cv|NN Perl_call_checker *ckfun_p|NN SV **ckobj_p +AMpd |void |cv_get_call_checker_sv|NN CV *cv|NN Perl_call_checker_sv *ckfun_p|NN SV **ckobj_p Apd |void |cv_set_call_checker|NN CV *cv|NN Perl_call_checker ckfun|NN SV *ckobj +AMpd |void |cv_set_call_checker_sv|NN CV *cv|NN Perl_call_checker_sv ckfun|NN SV *ckobj +#if defined(PERL_IN_OP_C) +s |MAGIC* |cv_set_call_checker_core|NN CV *cv|NN void *ckfun|NN SV *ckobj +#endif Apd |void |wrap_op_checker|Optype opcode|NN Perl_check_t new_checker|NN Perl_check_t *old_checker_p Apa |PERL_SI*|new_stackinfo|I32 stitems|I32 cxitems Ap |char* |scan_vstring |NN const char *s|NN const char *const e \ diff --git a/embed.h b/embed.h index c66eba9..c5154f4 100644 --- a/embed.h +++ b/embed.h @@ -77,6 +77,8 @@ #define ck_entersub_args_list(a) Perl_ck_entersub_args_list(aTHX_ a) #define ck_entersub_args_proto(a,b,c) Perl_ck_entersub_args_proto(aTHX_ a,b,c) #define ck_entersub_args_proto_or_list(a,b,c) Perl_ck_entersub_args_proto_or_list(aTHX_ a,b,c) +#define ck_entersub_args_proto_or_list_sv(a,b,c) Perl_ck_entersub_args_proto_or_list_sv(aTHX_ a,b,c) +#define ck_entersub_args_proto_sv(a,b,c) Perl_ck_entersub_args_proto_sv(aTHX_ a,b,c) #ifndef PERL_IMPLICIT_CONTEXT #define ck_warner Perl_ck_warner #define ck_warner_d Perl_ck_warner_d @@ -93,7 +95,9 @@ #define cv_clone(a) Perl_cv_clone(aTHX_ a) #define cv_const_sv(a) Perl_cv_const_sv(aTHX_ a) #define cv_get_call_checker(a,b,c) Perl_cv_get_call_checker(aTHX_ a,b,c) +#define cv_get_call_checker_sv(a,b,c) Perl_cv_get_call_checker_sv(aTHX_ a,b,c) #define cv_set_call_checker(a,b,c) Perl_cv_set_call_checker(aTHX_ a,b,c) +#define cv_set_call_checker_sv(a,b,c) Perl_cv_set_call_checker_sv(aTHX_ a,b,c) #define cv_undef(a) Perl_cv_undef(aTHX_ a) #define cx_dump(a) Perl_cx_dump(aTHX_ a) #define cxinc() Perl_cxinc(aTHX) @@ -1416,7 +1420,9 @@ #define apply_attrs_my(a,b,c,d) S_apply_attrs_my(aTHX_ a,b,c,d) #define bad_type_pv(a,b,c,d,e) S_bad_type_pv(aTHX_ a,b,c,d,e) #define bad_type_sv(a,b,c,d,e) S_bad_type_sv(aTHX_ a,b,c,d,e) +#define ck_entersub_args_proto_core(a,b,c,d) S_ck_entersub_args_proto_core(aTHX_ a,b,c,d) #define cop_free(a) S_cop_free(aTHX_ a) +#define cv_set_call_checker_core(a,b,c) S_cv_set_call_checker_core(aTHX_ a,b,c) #define dup_attrlist(a) S_dup_attrlist(aTHX_ a) #define finalize_op(a) S_finalize_op(aTHX_ a) #define find_and_forget_pmops(a) S_find_and_forget_pmops(aTHX_ a) @@ -1439,6 +1445,7 @@ #define no_fh_allowed(a) S_no_fh_allowed(aTHX_ a) #define op_integerize(a) S_op_integerize(aTHX_ a) #define op_std_init(a) S_op_std_init(aTHX_ a) +#define padcv_op_cv(a,b) S_padcv_op_cv(aTHX_ a,b) #define pmtrans(a,b,c) S_pmtrans(aTHX_ a,b,c) #define process_special_blocks(a,b,c,d) S_process_special_blocks(aTHX_ a,b,c,d) #define ref_array_or_hash(a) S_ref_array_or_hash(aTHX_ a) diff --git a/ext/XS-APItest/APItest.xs b/ext/XS-APItest/APItest.xs index dbb4f50..58d3c94 100644 --- a/ext/XS-APItest/APItest.xs +++ b/ext/XS-APItest/APItest.xs @@ -1124,6 +1124,9 @@ my_ck_rv2cv(pTHX_ OP *o) return old_ck_rv2cv(aTHX_ o); } +static OP * my_callchecker(pTHX_ OP *o, GV *g, SV *p) { return o; } +static OP * my_callchecker_sv(pTHX_ OP *o, SV *g, SV *p) { return o; } + #include "const-c.inc" MODULE = XS::APItest PACKAGE = XS::APItest @@ -1132,6 +1135,8 @@ INCLUDE: const-xs.inc INCLUDE: numeric.xs +INCLUDE: callchecker.xs + MODULE = XS::APItest::utf8 PACKAGE = XS::APItest::utf8 int diff --git a/ext/XS-APItest/callchecker.xs b/ext/XS-APItest/callchecker.xs new file mode 100644 index 0000000..0cba6dc --- /dev/null +++ b/ext/XS-APItest/callchecker.xs @@ -0,0 +1,51 @@ +MODULE = XS::APItest PACKAGE = XS::APItest::callchecker + +UV +callchecker_address() + CODE: + RETVAL = PTR2UV(my_callchecker); + OUTPUT: + RETVAL + +UV +callchecker_sv_address() + CODE: + RETVAL = PTR2UV(my_callchecker_sv); + OUTPUT: + RETVAL + +void +setcallchecker(cv) + CV * cv + CODE: + SV * ckobj = (SV *)cv; + cv_set_call_checker(cv, my_callchecker, ckobj); + +void +setcallchecker_sv(cv) + CV * cv + CODE: + SV * ckobj = (SV *)cv; + cv_set_call_checker_sv(cv, my_callchecker_sv, ckobj); + +UV +getcallchecker(cv) + CV * cv + CODE: + Perl_call_checker ckfun; + SV *ckobj; + cv_get_call_checker(cv, &ckfun, &ckobj); + RETVAL = PTR2UV(ckfun); + OUTPUT: + RETVAL + +UV +getcallchecker_sv(cv) + CV * cv + CODE: + Perl_call_checker_sv ckfun; + SV *ckobj; + cv_get_call_checker_sv(cv, &ckfun, &ckobj); + RETVAL = PTR2UV(ckfun); + OUTPUT: + RETVAL diff --git a/op.c b/op.c index c9a1b53..c9f64d9 100644 --- a/op.c +++ b/op.c @@ -8135,6 +8135,7 @@ Perl_newCVREF(pTHX_ I32 flags, OP *o) dVAR; o->op_type = OP_PADCV; o->op_ppaddr = PL_ppaddr[OP_PADCV]; + o->op_private = (U8)(1 | flags >> 8); return o; } return newUNOP(OP_RV2CV, flags, scalar(o)); @@ -9890,24 +9891,7 @@ Perl_rv2cv_op_cv(pTHX_ OP *cvop, U32 flags) gv = NULL; } break; case OP_PADCV: { - PADNAME *name = PAD_COMPNAME(rvop->op_targ); - CV *compcv = PL_compcv; - PADOFFSET off = rvop->op_targ; - while (PadnameOUTER(name)) { - assert(PARENT_PAD_INDEX(name)); - compcv = CvOUTSIDE(PL_compcv); - name = PadlistNAMESARRAY(CvPADLIST(compcv)) - [off = PARENT_PAD_INDEX(name)]; - } - assert(!PadnameIsOUR(name)); - if (!PadnameIsSTATE(name)) { - MAGIC * mg = mg_find(name, PERL_MAGIC_proto); - assert(mg); - assert(mg->mg_obj); - cv = (CV *)mg->mg_obj; - } - else cv = - (CV *)AvARRAY(PadlistARRAY(CvPADLIST(compcv))[1])[off]; + cv = padcv_op_cv(rvop, NULL); gv = NULL; } break; default: { @@ -9925,6 +9909,33 @@ Perl_rv2cv_op_cv(pTHX_ OP *cvop, U32 flags) } } +STATIC CV * +S_padcv_op_cv(pTHX_ OP *padcvop, SV ** namesv) +{ + PADOFFSET off = padcvop->op_targ; + PADNAME *name = PAD_COMPNAME(off); + CV *compcv = PL_compcv; + CV *retcv = NULL; + while (PadnameOUTER(name)) { + assert(PARENT_PAD_INDEX(name)); + compcv = CvOUTSIDE(PL_compcv); + name = PadlistNAMESARRAY(CvPADLIST(compcv))[off = PARENT_PAD_INDEX(name)]; + } + assert(!PadnameIsOUR(name)); + if (!PadnameIsSTATE(name)) { + MAGIC * mg = mg_find(name, PERL_MAGIC_proto); + assert(mg); + assert(mg->mg_obj); + retcv = (CV *)mg->mg_obj; + } + else retcv = (CV *)AvARRAY(PadlistARRAY(CvPADLIST(compcv))[1])[off]; + if (namesv) + *namesv = sv_2mortal(newSVpvn_utf8( + PadnamePV(name)+1,PadnameLEN(name)-1, PadnameUTF8(name) + )); + return retcv; +} + /* =for apidoc Am|OP *|ck_entersub_args_list|OP *entersubop @@ -9986,6 +9997,29 @@ by the name defined by the I parameter. OP * Perl_ck_entersub_args_proto(pTHX_ OP *entersubop, GV *namegv, SV *protosv) { + PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_PROTO; + return ck_entersub_args_proto_core(entersubop, (void *)namegv, protosv, TRUE); +} + +/* +=for apidoc AMpd|OP *|ck_entersub_args_proto_sv|OP *entersubop|SV *namegv|SV *protosv + +An alternative interface for L which takes a C +instead of a C. + +=cut +*/ + +OP * +Perl_ck_entersub_args_proto_sv(pTHX_ OP *entersubop, SV *namesv, SV *protosv) +{ + PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_PROTO_SV; + return ck_entersub_args_proto_core(entersubop, (void *)namesv, protosv, FALSE); +} + +STATIC OP * +S_ck_entersub_args_proto_core(pTHX_ OP *entersubop, void *namev, SV *protosv, bool name_is_gv) +{ STRLEN proto_len; const char *proto, *proto_end; OP *aop, *prev, *cvop; @@ -9993,7 +10027,7 @@ Perl_ck_entersub_args_proto(pTHX_ OP *entersubop, GV *namegv, SV *protosv) I32 arg = 0; I32 contextclass = 0; const char *e = NULL; - PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_PROTO; + SV * namesv = (name_is_gv ? gv_ename((GV *)namev) : (SV *)namev); if (SvTYPE(protosv) == SVt_PVCV ? !SvPOK(protosv) : !SvOK(protosv)) Perl_croak(aTHX_ "panic: ck_entersub_args_proto CV with no proto, " "flags=%lx", (unsigned long) SvFLAGS(protosv)); @@ -10019,7 +10053,7 @@ Perl_ck_entersub_args_proto(pTHX_ OP *entersubop, GV *namegv, SV *protosv) o3 = aop; if (proto >= proto_end) - return too_many_arguments_sv(entersubop, gv_ename(namegv), 0); + return too_many_arguments_sv(entersubop, namesv, 0); switch (*proto) { case ';': @@ -10046,7 +10080,7 @@ Perl_ck_entersub_args_proto(pTHX_ OP *entersubop, GV *namegv, SV *protosv) if (o3->op_type != OP_REFGEN && o3->op_type != OP_UNDEF) bad_type_sv(arg, arg == 1 ? "block or sub {}" : "sub {}", - gv_ename(namegv), 0, o3); + namesv, 0, o3); break; case '*': /* '*' allows any scalar type, including bareword */ @@ -10133,7 +10167,7 @@ Perl_ck_entersub_args_proto(pTHX_ OP *entersubop, GV *namegv, SV *protosv) )) goto wrapref; bad_type_sv(arg, Perl_form(aTHX_ "one of %.*s", (int)(end - p), p), - gv_ename(namegv), 0, o3); + namesv, 0, o3); } else goto oops; break; @@ -10141,13 +10175,13 @@ Perl_ck_entersub_args_proto(pTHX_ OP *entersubop, GV *namegv, SV *protosv) if (o3->op_type == OP_RV2GV) goto wrapref; if (!contextclass) - bad_type_sv(arg, "symbol", gv_ename(namegv), 0, o3); + bad_type_sv(arg, "symbol", namesv, 0, o3); break; case '&': if (o3->op_type == OP_ENTERSUB) goto wrapref; if (!contextclass) - bad_type_sv(arg, "subroutine entry", gv_ename(namegv), 0, + bad_type_sv(arg, "subroutine entry", namesv, 0, o3); break; case '$': @@ -10163,7 +10197,7 @@ Perl_ck_entersub_args_proto(pTHX_ OP *entersubop, GV *namegv, SV *protosv) OP_READ, /* not entersub */ OP_LVALUE_NO_CROAK )) goto wrapref; - bad_type_sv(arg, "scalar", gv_ename(namegv), 0, o3); + bad_type_sv(arg, "scalar", namesv, 0, o3); } break; case '@': @@ -10171,14 +10205,14 @@ Perl_ck_entersub_args_proto(pTHX_ OP *entersubop, GV *namegv, SV *protosv) o3->op_type == OP_PADAV) goto wrapref; if (!contextclass) - bad_type_sv(arg, "array", gv_ename(namegv), 0, o3); + bad_type_sv(arg, "array", namesv, 0, o3); break; case '%': if (o3->op_type == OP_RV2HV || o3->op_type == OP_PADHV) goto wrapref; if (!contextclass) - bad_type_sv(arg, "hash", gv_ename(namegv), 0, o3); + bad_type_sv(arg, "hash", namesv, 0, o3); break; wrapref: { @@ -10204,10 +10238,8 @@ Perl_ck_entersub_args_proto(pTHX_ OP *entersubop, GV *namegv, SV *protosv) continue; default: oops: { - SV* const tmpsv = sv_newmortal(); - gv_efullname3(tmpsv, namegv, NULL); Perl_croak(aTHX_ "Malformed prototype for %"SVf": %"SVf, - SVfARG(tmpsv), SVfARG(protosv)); + SVfARG(namesv), SVfARG(protosv)); } } @@ -10223,7 +10255,7 @@ Perl_ck_entersub_args_proto(pTHX_ OP *entersubop, GV *namegv, SV *protosv) } if (!optional && proto_end > proto && (*proto != '@' && *proto != '%' && *proto != ';' && *proto != '_')) - return too_few_arguments_sv(entersubop, gv_ename(namegv), 0); + return too_few_arguments_sv(entersubop, namesv, 0); return entersubop; } @@ -10265,6 +10297,27 @@ Perl_ck_entersub_args_proto_or_list(pTHX_ OP *entersubop, return ck_entersub_args_list(entersubop); } +/* +=for apidoc AMpd|OP *|ck_entersub_args_proto_or_list_sv|OP *entersubop|SV *namesv|SV *protosv + +Equivalent to L, but passes the name of +the function as an C rather than a C, since not all functions +have a C to store a name. + +=cut +*/ + +OP * +Perl_ck_entersub_args_proto_or_list_sv(pTHX_ OP *entersubop, + SV *namesv, SV *protosv) +{ + PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_PROTO_OR_LIST_SV; + if (SvTYPE(protosv) == SVt_PVCV ? SvPOK(protosv) : SvOK(protosv)) + return ck_entersub_args_proto_sv(entersubop, namesv, protosv); + else + return ck_entersub_args_list(entersubop); +} + OP * Perl_ck_entersub_args_core(pTHX_ OP *entersubop, GV *namegv, SV *protosv) { @@ -10385,6 +10438,26 @@ and the SV parameter is I itself. This implements standard prototype processing. It can be changed, for a particular subroutine, by L. +See L for an alternative version which uses +I instead of I. + +There are two differences between the functions: + +=over 4 + +=item * + +The L returns a function which takes +an C instead of a C (set by L + +=item * + +L will croak if the call checker is not the +default and is not the right type; L +will set the function pointer to NULL instead. + +=back + =cut */ @@ -10394,9 +10467,20 @@ Perl_cv_get_call_checker(pTHX_ CV *cv, Perl_call_checker *ckfun_p, SV **ckobj_p) MAGIC *callmg; PERL_ARGS_ASSERT_CV_GET_CALL_CHECKER; callmg = SvMAGICAL((SV*)cv) ? mg_find((SV*)cv, PERL_MAGIC_checkcall) : NULL; - if (callmg) { + if (callmg && callmg->mg_private == 0) { *ckfun_p = DPTR2FPTR(Perl_call_checker, callmg->mg_ptr); *ckobj_p = callmg->mg_obj; + } else if (callmg && callmg->mg_private == 1) { + /* If it's still set to the default, return the origianl default call checker */ + if (callmg->mg_ptr == (char *)Perl_ck_entersub_args_proto_or_list_sv) { + *ckfun_p = Perl_ck_entersub_args_proto_or_list; + *ckobj_p = (SV*)cv; + } else { + SV *xpt = Perl_newSVpvf(aTHX_ + "cv_get_call_checker cannot return a value set by cv_get_call_checker_sv"); + Perl_sv_2mortal(aTHX_ xpt); + Perl_croak_sv(aTHX_ xpt); + } } else { *ckfun_p = Perl_ck_entersub_args_proto_or_list; *ckobj_p = (SV*)cv; @@ -10404,6 +10488,65 @@ Perl_cv_get_call_checker(pTHX_ CV *cv, Perl_call_checker *ckfun_p, SV **ckobj_p) } /* +=for apidoc AMpd|void|cv_get_call_checker_sv|CV *cv|Perl_call_checker_sv *ckfun_p|SV **ckobj_p + +See L for details. + +=cut +*/ + +void +Perl_cv_get_call_checker_sv(pTHX_ CV *cv, Perl_call_checker_sv *ckfun_p, SV **ckobj_p) +{ + MAGIC *callmg; + PERL_ARGS_ASSERT_CV_GET_CALL_CHECKER_SV; + callmg = SvMAGICAL((SV*)cv) ? mg_find((SV*)cv, PERL_MAGIC_checkcall) : NULL; + if (callmg && callmg->mg_private == 1) { + *ckfun_p = DPTR2FPTR(Perl_call_checker_sv, callmg->mg_ptr); + *ckobj_p = callmg->mg_obj; + } else if (callmg && callmg->mg_private == 0) { + *ckfun_p = NULL; + *ckobj_p = callmg->mg_obj; + } else { + *ckfun_p = Perl_ck_entersub_args_proto_or_list_sv; + *ckobj_p = (SV*)cv; + } +} + +/* Utility function for common code between cv_set_call_checker(|_sv) */ + +STATIC MAGIC * +S_cv_set_call_checker_core(pTHX_ CV *cv, void *ckfun, SV *ckobj) +{ + PERL_ARGS_ASSERT_CV_SET_CALL_CHECKER_CORE; + if (ckfun == Perl_ck_entersub_args_proto_or_list && ckobj == (SV*)cv) { + if (SvMAGICAL((SV*)cv)) + mg_free_type((SV*)cv, PERL_MAGIC_checkcall); + } else if (ckfun == Perl_ck_entersub_args_proto_or_list_sv && ckobj == (SV*)cv) { + /* If this version is desired, cv_get_call_checker will return it */ + if (SvMAGICAL((SV*)cv)) + mg_free_type((SV*)cv, PERL_MAGIC_checkcall); + } else { + MAGIC *callmg; + sv_magic((SV*)cv, &PL_sv_undef, PERL_MAGIC_checkcall, NULL, 0); + callmg = mg_find((SV*)cv, PERL_MAGIC_checkcall); + if (callmg->mg_flags & MGf_REFCOUNTED) { + SvREFCNT_dec(callmg->mg_obj); + callmg->mg_flags &= ~MGf_REFCOUNTED; + } + callmg->mg_ptr = FPTR2DPTR(char *, ckfun); + callmg->mg_obj = ckobj; + if (ckobj != (SV*)cv) { + SvREFCNT_inc_simple_void_NN(ckobj); + callmg->mg_flags |= MGf_REFCOUNTED; + } + callmg->mg_flags |= MGf_COPY; + return callmg; + } + return NULL; +} + +/* =for apidoc Am|void|cv_set_call_checker|CV *cv|Perl_call_checker ckfun|SV *ckobj Sets the function that will be used to fix up a call to I. @@ -10427,6 +10570,16 @@ such as to a call to a different subroutine or to a method call. The current setting for a particular CV can be retrieved by L. +See L for an alternative version which uses +I instead of I. If +L is used to set the call checker, +L must be used to retrieve it. Likewise, +if L is used to set the call checker, +L must be used to retrieve it. The sole +exception to this rule is the default call checker; if the call checker +is never set, or is set back to the default, each get call checker +functions will return the appropriate version. + =cut */ @@ -10434,25 +10587,26 @@ void Perl_cv_set_call_checker(pTHX_ CV *cv, Perl_call_checker ckfun, SV *ckobj) { PERL_ARGS_ASSERT_CV_SET_CALL_CHECKER; - if (ckfun == Perl_ck_entersub_args_proto_or_list && ckobj == (SV*)cv) { - if (SvMAGICAL((SV*)cv)) - mg_free_type((SV*)cv, PERL_MAGIC_checkcall); - } else { - MAGIC *callmg; - sv_magic((SV*)cv, &PL_sv_undef, PERL_MAGIC_checkcall, NULL, 0); - callmg = mg_find((SV*)cv, PERL_MAGIC_checkcall); - if (callmg->mg_flags & MGf_REFCOUNTED) { - SvREFCNT_dec(callmg->mg_obj); - callmg->mg_flags &= ~MGf_REFCOUNTED; - } - callmg->mg_ptr = FPTR2DPTR(char *, ckfun); - callmg->mg_obj = ckobj; - if (ckobj != (SV*)cv) { - SvREFCNT_inc_simple_void_NN(ckobj); - callmg->mg_flags |= MGf_REFCOUNTED; - } - callmg->mg_flags |= MGf_COPY; - } + cv_set_call_checker_core(cv, (void *)ckfun, ckobj); +} + +/* +=for apidoc Am|void|cv_set_call_checker_sv|CV *cv|Perl_call_checker_sv *ckfun_p|SV **ckobj_p + +See L for more details. The difference between the two versions is +limited to the I function taking a SV * instead of a GV * for the name +of the function, since not all functions will have a GV. + +=cut +*/ + +void +Perl_cv_set_call_checker_sv(pTHX_ CV *cv, Perl_call_checker_sv ckfun, SV *ckobj) +{ + PERL_ARGS_ASSERT_CV_SET_CALL_CHECKER_SV; + MAGIC * callmg = cv_set_call_checker_core(cv, (void *)ckfun, ckobj); + if (callmg) + callmg->mg_private = 1; } OP * @@ -10461,6 +10615,7 @@ Perl_ck_subr(pTHX_ OP *o) OP *aop, *cvop; CV *cv; GV *namegv; + SV *namesv; PERL_ARGS_ASSERT_CK_SUBR; @@ -10469,8 +10624,14 @@ Perl_ck_subr(pTHX_ OP *o) aop = cUNOPx(aop)->op_first; aop = aop->op_sibling; for (cvop = aop; cvop->op_sibling; cvop = cvop->op_sibling) ; - cv = rv2cv_op_cv(cvop, RV2CVOPCV_MARK_EARLY); - namegv = cv ? (GV*)rv2cv_op_cv(cvop, RV2CVOPCV_RETURN_NAME_GV) : NULL; + if (cvop->op_type == OP_PADCV && !(cvop->op_private & OPpENTERSUB_AMPER)) { + cv = padcv_op_cv(cvop, &namesv); + namegv = NULL; + } else { + cv = rv2cv_op_cv(cvop, RV2CVOPCV_MARK_EARLY); + namegv = cv ? (GV*)rv2cv_op_cv(cvop, RV2CVOPCV_RETURN_NAME_GV) : NULL; + namesv = namegv ? gv_ename(namegv) : sv_2mortal(newSVpvs("__ANON__::__ANON__")); + } o->op_private &= ~1; o->op_private |= OPpENTERSUB_HASTARG; @@ -10496,20 +10657,25 @@ Perl_ck_subr(pTHX_ OP *o) Perl_call_checker ckfun; SV *ckobj; cv_get_call_checker(cv, &ckfun, &ckobj); - if (!namegv) { /* expletive! */ - /* XXX The call checker API is public. And it guarantees that - a GV will be provided with the right name. So we have - to create a GV. But it is still not correct, as its - stringification will include the package. What we - really need is a new call checker API that accepts a - GV or string (or GV or CV). */ - HEK * const hek = CvNAME_HEK(cv); - assert(hek); - namegv = (GV *)sv_newmortal(); - gv_init_pvn(namegv, PL_curstash, HEK_KEY(hek), HEK_LEN(hek), - SVf_UTF8 * !!HEK_UTF8(hek)); - } - return ckfun(aTHX_ o, namegv, ckobj); + /* If a GV* call checker is in place, use it, otherwise use the SV* style */ + if (ckfun != Perl_ck_entersub_args_proto_or_list) { + if (!namegv) { /* expletive! */ + /* XXX The call checker API is public. And it guarantees that + a GV will be provided with the right name. So we have + to create a GV. But it is still not correct, as its + stringification will include the package. */ + HEK * const hek = CvNAME_HEK(cv); + assert(hek); + namegv = (GV *)sv_newmortal(); + gv_init_pvn(namegv, PL_curstash, HEK_KEY(hek), HEK_LEN(hek), + SVf_UTF8 * !!HEK_UTF8(hek)); + } + return ckfun(aTHX_ o, namegv, ckobj); + } else { + Perl_call_checker_sv ckfun; + cv_get_call_checker_sv(cv, &ckfun, &ckobj); + return ckfun(aTHX_ o, namesv, ckobj); + } } } diff --git a/proto.h b/proto.h index 18f46cc..a323100 100644 --- a/proto.h +++ b/proto.h @@ -418,6 +418,20 @@ PERL_CALLCONV OP* Perl_ck_entersub_args_proto_or_list(pTHX_ OP *entersubop, GV * #define PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_PROTO_OR_LIST \ assert(entersubop); assert(namegv); assert(protosv) +PERL_CALLCONV OP* Perl_ck_entersub_args_proto_or_list_sv(pTHX_ OP *entersubop, SV *namesv, SV *protosv) + __attribute__nonnull__(pTHX_1) + __attribute__nonnull__(pTHX_2) + __attribute__nonnull__(pTHX_3); +#define PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_PROTO_OR_LIST_SV \ + assert(entersubop); assert(namesv); assert(protosv) + +PERL_CALLCONV OP* Perl_ck_entersub_args_proto_sv(pTHX_ OP *entersubop, SV *namesv, SV *protosv) + __attribute__nonnull__(pTHX_1) + __attribute__nonnull__(pTHX_2) + __attribute__nonnull__(pTHX_3); +#define PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_PROTO_SV \ + assert(entersubop); assert(namesv); assert(protosv) + PERL_CALLCONV OP * Perl_ck_eof(pTHX_ OP *o) __attribute__warn_unused_result__ __attribute__nonnull__(pTHX_1); @@ -758,6 +772,13 @@ PERL_CALLCONV void Perl_cv_get_call_checker(pTHX_ CV *cv, Perl_call_checker *ckf #define PERL_ARGS_ASSERT_CV_GET_CALL_CHECKER \ assert(cv); assert(ckfun_p); assert(ckobj_p) +PERL_CALLCONV void Perl_cv_get_call_checker_sv(pTHX_ CV *cv, Perl_call_checker_sv *ckfun_p, SV **ckobj_p) + __attribute__nonnull__(pTHX_1) + __attribute__nonnull__(pTHX_2) + __attribute__nonnull__(pTHX_3); +#define PERL_ARGS_ASSERT_CV_GET_CALL_CHECKER_SV \ + assert(cv); assert(ckfun_p); assert(ckobj_p) + PERL_CALLCONV void Perl_cv_set_call_checker(pTHX_ CV *cv, Perl_call_checker ckfun, SV *ckobj) __attribute__nonnull__(pTHX_1) __attribute__nonnull__(pTHX_2) @@ -765,6 +786,13 @@ PERL_CALLCONV void Perl_cv_set_call_checker(pTHX_ CV *cv, Perl_call_checker ckfu #define PERL_ARGS_ASSERT_CV_SET_CALL_CHECKER \ assert(cv); assert(ckfun); assert(ckobj) +PERL_CALLCONV void Perl_cv_set_call_checker_sv(pTHX_ CV *cv, Perl_call_checker_sv ckfun, SV *ckobj) + __attribute__nonnull__(pTHX_1) + __attribute__nonnull__(pTHX_2) + __attribute__nonnull__(pTHX_3); +#define PERL_ARGS_ASSERT_CV_SET_CALL_CHECKER_SV \ + assert(cv); assert(ckfun); assert(ckobj) + PERL_CALLCONV void Perl_cv_undef(pTHX_ CV* cv) __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_CV_UNDEF \ @@ -5863,11 +5891,25 @@ STATIC void S_bad_type_sv(pTHX_ I32 n, const char *t, SV *namesv, U32 flags, con #define PERL_ARGS_ASSERT_BAD_TYPE_SV \ assert(t); assert(namesv); assert(kid) +STATIC OP* S_ck_entersub_args_proto_core(pTHX_ OP *entersubop, void *namev, SV *protosv, bool name_is_gv) + __attribute__nonnull__(pTHX_1) + __attribute__nonnull__(pTHX_2) + __attribute__nonnull__(pTHX_3); +#define PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_PROTO_CORE \ + assert(entersubop); assert(namev); assert(protosv) + STATIC void S_cop_free(pTHX_ COP *cop) __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_COP_FREE \ assert(cop) +STATIC MAGIC* S_cv_set_call_checker_core(pTHX_ CV *cv, void *ckfun, SV *ckobj) + __attribute__nonnull__(pTHX_1) + __attribute__nonnull__(pTHX_2) + __attribute__nonnull__(pTHX_3); +#define PERL_ARGS_ASSERT_CV_SET_CALL_CHECKER_CORE \ + assert(cv); assert(ckfun); assert(ckobj) + STATIC OP * S_dup_attrlist(pTHX_ OP *o) __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_DUP_ATTRLIST \ @@ -5962,6 +6004,11 @@ PERL_STATIC_INLINE OP* S_op_std_init(pTHX_ OP *o) #define PERL_ARGS_ASSERT_OP_STD_INIT \ assert(o) +STATIC CV* S_padcv_op_cv(pTHX_ OP *padcvop, SV ** namesv) + __attribute__nonnull__(pTHX_1); +#define PERL_ARGS_ASSERT_PADCV_OP_CV \ + assert(padcvop) + STATIC OP* S_pmtrans(pTHX_ OP* o, OP* expr, OP* repl) __attribute__nonnull__(pTHX_1) __attribute__nonnull__(pTHX_2) diff --git a/t/cmd/lexsub.t b/t/cmd/lexsub.t index 86c7e26..5f715fd 100644 --- a/t/cmd/lexsub.t +++ b/t/cmd/lexsub.t @@ -8,7 +8,7 @@ BEGIN { *bar::like = *like; } no warnings 'deprecated'; -plan 128; +plan 129; # -------------------- Errors with feature disabled -------------------- # @@ -86,6 +86,8 @@ sub bar::c { 43 } { our sub e ($); is prototype "::e", '$', 'our sub with proto'; + eval "e(1,2);"; + like $@, qq 'Too many arguments for main::e at', 'prototypes honored with parens'; } { our sub if() { 42 } @@ -415,12 +417,12 @@ sub mc { 43 } } package main; { - my sub me ($); + sub me ($); is prototype eval{\&me}, '$', 'my sub with proto'; - is prototype "me", undef, 'prototype "..." ignores my subs'; + is prototype "me", '$', 'prototype "..." ignores my subs'; } { - my sub if() { 44 } + my sub if { 44 } my $x = if if if; is $x, 44, 'my subs override all keywords'; package bar; ```

p5pRT commented 10 years ago

From @cpansprout

On Fri Sep 12 00:26:55 2014\, sprout wrote:

I do think it is over-engineered and that cv_set_call_checker_flags is a better solution.

BTW\, have you seen what I am doing on the sprout/cvgv branch? It is almost ready for merging\, but not quite. Maybe a few more days. In any case\, ‘sub foo{} foo() \&foo’ no longer has to create a *foo glob\, saving memory.

It is now in blead as merge commit f9d9e965c. The new call checker API is in commit aa38f4b16\, and cv_name was added in c5569a55\, fb094047 and b5e03f43ef.

--

Father Chrysostomos

p5pRT commented 10 years ago

@cpansprout - Status changed from 'open' to 'resolved'

p5pRT commented 10 years ago

From @bulk88

On Mon Sep 15 08:31:16 2014\, sprout wrote:

It is now in blead as merge commit f9d9e965c. The new call checker API is in commit aa38f4b16\, and cv_name was added in c5569a55\, fb094047 and b5e03f43ef.

Bug needs to be reopened.

Visual C 2003 is complaining of new warnings because of these commits.

cl -c -nologo -GF -W3 -I..\lib\CORE -I.\include -I. -I.. -DWIN32 -D_CONSOLE -DNO_STRICT -DPERLDLL -DPERL_CORE -O1 -MD -Zi -DNDEBUG -G7 -GL -DPERL_EXTERNAL_GLOB -DPERL_IS_MINIPERL -Fo.\mini\op.obj ..\op.c op.c op.c(7897) : warning C4146: unary minus operator applied to unsigned type\, result still unsigned op.c(7958) : warning C4146: unary minus operator applied to unsigned type\, result still unsigned op.c(10751) : warning C4098: 'Perl_cv_get_call_checker' : 'void' function returning a value op.c(10825) : warning C4244: '=' : conversion from 'U32' to 'U8'\, possible loss of data

line 7897 7958 comes from Sept 15 2014 commit http://perl5.git.perl.org/perl.git/commit/2eaf799e74b14dc77b90d5484a3fd4ceac12b46a

line 10751 comes from Sept 15 2014 commit http://perl5.git.perl.org/perl.git/commit/9c98a81fd30898ed03895d1368f4f9f2761b69da

line 10825 comes from Sept 15 2014 commit http://perl5.git.perl.org/perl.git/commit/aa38f4b16ec84f790a5473b0ff1ffe264bd93f5a

-- bulk88 ~ bulk88 at hotmail.com

p5pRT commented 10 years ago

From @cpansprout

On Mon Sep 15 17:43:35 2014\, bulk88 wrote:

On Mon Sep 15 08:31:16 2014\, sprout wrote:

It is now in blead as merge commit f9d9e965c. The new call checker API is in commit aa38f4b16\, and cv_name was added in c5569a55\, fb094047 and b5e03f43ef.

Bug needs to be reopened.

Visual C 2003 is complaining of new warnings because of these commits.

cl -c -nologo -GF -W3 -I..\lib\CORE -I.\include -I. -I.. -DWIN32 -D_CONSOLE -DNO_STRICT -DPERLDLL -DPERL_CORE -O1 -MD -Zi -DNDEBUG -G7 -GL -DPERL_EXTERNAL_GLOB -DPERL_IS_MINIPERL -Fo.\mini\op.obj ..\op.c op.c op.c(7897) : warning C4146: unary minus operator applied to unsigned type\, result still unsigned op.c(7958) : warning C4146: unary minus operator applied to unsigned type\, result still unsigned op.c(10751) : warning C4098: 'Perl_cv_get_call_checker' : 'void' function returning a value op.c(10825) : warning C4244: '=' : conversion from 'U32' to 'U8'\, possible loss of data

Thank you.

line 7897 7958 comes from Sept 15 2014 commit http://perl5.git.perl.org/perl.git/commit/2eaf799e74b14dc77b90d5484a3fd4ceac12b46a

Oops.

line 10751 comes from Sept 15 2014 commit http://perl5.git.perl.org/perl.git/commit/9c98a81fd30898ed03895d1368f4f9f2761b69da

Oops.

line 10825 comes from Sept 15 2014 commit http://perl5.git.perl.org/perl.git/commit/aa38f4b16ec84f790a5473b0ff1ffe264bd93f5a

Dumb compiler\, but whatever.

I have fixed\, or at least hope I have fixed\, these in 53d063424.

--

Father Chrysostomos

Perl / perl5