Skip Menu |
Report information
Id: 77974
Status: rejected
Priority: 0/
Queue: perl5

Owner: Nobody
Requestors: ben [at] morrow.me.uk
Cc:
AdminCc:

Operating System: All
PatchStatus: Obsolete
Severity: Wishlist
Type:
Perl Version: 5.12.0
Fixed In: (no value)

Attachments
0001-Record-method-calls-in-the-context-stack.patch
0002-Make-all-the-magic-method-calls-method-calls.patch
0002-Tests-for-OPpENTERSUB_METHOD.patch
0003-Fix-attribute-method-calls-to-be-method-calls.patch
0003-Make-all-the-magic-method-calls-method-calls.patch
0004-Fix-attribute-method-calls-to-be-method-calls.patch
0004-Tests-for-OPpENTERSUB_METHOD.patch
0005-Tell-the-debugger-about-method-calls.patch
0006-make-regen.patch
0006-Test-DB-method.patch
0007-Test-DB-method.patch
0008-Update-MANIFEST.patch
0009-Fixup-the-tests-in-ext-B-for-OPpENTERSUB_METHOD.patch



Subject: [PATCH] Record method calls in the context stack
Date: Wed, 22 Sep 2010 00:15:01 +0100
To: perlbug [...] perl.org
From: Ben Morrow <ben [...] morrow.me.uk>
Download (untitled) / with headers
text/plain 1.3k
These patches record whether a given stack frame is for a function or a method call, by adding a new OPpENTERSUB_PRIVATE bit. I need this for PRE and POST blocks, which have different behaviour depending on whether a sub is called as a method or not. I looked at Devel::Caller::called_as_method, but unfortunately it gets all but the simplest cases wrong; for instance: ~% perl -MDevel::Caller::called_as_method -E'sub foo { say "method: " . called_as_method } foo and main->foo' method: method: While this particular bug could possibly be fixed, the general approach (starting at the previous COP and tracing forward to find the right entersub OP) will necessarily fail in the case of calls made through call_* (from the core or from XS), since the OPs created there aren't in the optree at all. I haven't attempted to export the flag to Perl, since I don't see anything wrong with leaving Devel::Caller::called_as_method as the way to get at this. I have, however, added a $DB::method variable, which is set whenever $DB::sub is and indicates whether this is a method or a function call. I'm not entirely sure about the parts of this which touch B: it's in ext/, so I presume it's not dual-life, but there seem to be lots of dual-life-ish bits of code in there. I haven't made any attempt to preserve compat with older perls; is this wrong? Ben
From 10a43d3cee842cb92a7a9e44126f5fc04ec9b688 Mon Sep 17 00:00:00 2001 From: Ben Morrow <ben@morrow.me.uk> Date: Sat, 18 Sep 2010 18:56:57 +0100 Subject: [PATCH 1/9] Record method calls in the context stack. Some core method calls are actually made as function calls, with an explicit lookup of the method to call beforehand (that is, as the C equivalent of my $meth = $obj->can("whatever"); $meth->($obj, @args); ). In order to ensure these are properly marked as method calls, we need a new G_FAKINGMETH flag to call_*. It would probably be cleaner to make them proper method calls; that is, the C equivalent of my $meth = $obj->can("whatever"); $obj->$meth(@args); but for now I'll leave them as they are. --- cop.h | 4 +++- ext/B/B/Concise.pm | 2 +- op.c | 1 + op.h | 4 +++- perl.c | 5 +++++ pp_sys.c | 2 +- 6 files changed, 14 insertions(+), 4 deletions(-) diff --git a/cop.h b/cop.h index 4791c80..dd90d5b 100644 --- a/cop.h +++ b/cop.h @@ -337,7 +337,7 @@ struct block_format { #define PUSHSUB(cx) \ PUSHSUB_BASE(cx) \ cx->blk_u16 = PL_op->op_private & \ - (OPpLVAL_INTRO|OPpENTERSUB_INARGS); + (OPpENTERSUB_METHOD|OPpLVAL_INTRO|OPpENTERSUB_INARGS); /* variant for use by OP_DBSTATE, where op_private holds hint bits */ #define PUSHSUB_DB(cx) \ @@ -766,6 +766,8 @@ L<perlcall>. #define G_UNDEF_FILL 512 /* Fill the stack with &PL_sv_undef A special case for UNSHIFT in Perl_magic_methcall(). */ +#define G_FAKINGMETH 1024 /* Faking a method call (we've already + done the lookup) */ /* flag bits for PL_in_eval */ #define EVAL_NULL 0 /* not in an eval */ diff --git a/ext/B/B/Concise.pm b/ext/B/B/Concise.pm index 53afe83..96de5b9 100644 --- a/ext/B/B/Concise.pm +++ b/ext/B/B/Concise.pm @@ -610,7 +610,7 @@ $priv{$_}{4} = "DREFed" for (qw(rv2sv rv2av rv2hv)); @{$priv{$_}}{32,64,96} = ("DREFAV", "DREFHV", "DREFSV") for (qw(rv2gv rv2sv padsv aelem helem)); $priv{$_}{16} = "STATE" for ("padav", "padhv", "padsv"); -@{$priv{"entersub"}}{16,32,64} = ("DBG","TARG","NOMOD"); +@{$priv{"entersub"}}{1,2,16,32,64} = ("TARG","STRICT","DBG","METH","NOMOD"); @{$priv{$_}}{4,8,128} = ("INARGS","AMPER","NO()") for ("entersub", "rv2cv"); $priv{"gv"}{32} = "EARLYCV"; $priv{"aelem"}{16} = $priv{"helem"}{16} = "LVDEFER"; diff --git a/op.c b/op.c index db91cdb..8e4eac5 100644 --- a/op.c +++ b/op.c @@ -8449,6 +8449,7 @@ Perl_ck_subr(pTHX_ OP *o) } } else if (cvop->op_type == OP_METHOD || cvop->op_type == OP_METHOD_NAMED) { + o->op_private |= OPpENTERSUB_METHOD; if (o2->op_type == OP_CONST) o2->op_private &= ~OPpCONST_STRICT; else if (o2->op_type == OP_LIST) { diff --git a/op.h b/op.h index da280b8..2c0784c 100644 --- a/op.h +++ b/op.h @@ -200,8 +200,10 @@ Deprecated. Use C<GIMME_V> instead. #define OPpDEREFed 4 /* prev op was OPpDEREF */ /* OP_ENTERSUB only */ #define OPpENTERSUB_DB 16 /* Debug subroutine. */ -#define OPpENTERSUB_HASTARG 32 /* Called from OP tree. */ +#define OPpENTERSUB_HASTARG 1 /* Called from OP tree. */ #define OPpENTERSUB_NOMOD 64 /* Immune to mod() for :attrlist. */ +#define OPpENTERSUB_METHOD 32 /* This is a method call */ +/* OP_ENTERSUB also uses HINT_STRICT_REFS (= 2) */ /* OP_ENTERSUB and OP_RV2CV only */ #define OPpENTERSUB_AMPER 8 /* Used & form to call. */ #define OPpENTERSUB_NOPAREN 128 /* bare sub call (without parens) */ diff --git a/perl.c b/perl.c index cf42087..6a64de0 100644 --- a/perl.c +++ b/perl.c @@ -2594,9 +2594,14 @@ Perl_call_sv(pTHX_ SV *sv, VOL I32 flags) method_op.op_type = OP_METHOD; myop.op_ppaddr = PL_ppaddr[OP_ENTERSUB]; myop.op_type = OP_ENTERSUB; + myop.op_private |= OPpENTERSUB_METHOD; PL_op = (OP*)&method_op; } + if (flags & G_FAKINGMETH) { + myop.op_private |= OPpENTERSUB_METHOD; + } + if (!(flags & G_EVAL)) { CATCH_SET(TRUE); CALL_BODY_SUB((OP*)&myop); diff --git a/pp_sys.c b/pp_sys.c index 1bc072d..0dcca28 100644 --- a/pp_sys.c +++ b/pp_sys.c @@ -872,7 +872,7 @@ PP(pp_tie) while (items--) PUSHs(*MARK++); PUTBACK; - call_sv(MUTABLE_SV(GvCV(gv)), G_SCALAR); + call_sv(MUTABLE_SV(GvCV(gv)), G_SCALAR|G_FAKINGMETH); } SPAGAIN; -- 1.7.1.1
From 2cfc2cb7deeac1ecc4d7aa3eaf9a1b97bc8c0c58 Mon Sep 17 00:00:00 2001 From: Ben Morrow <ben@morrow.me.uk> Date: Mon, 20 Sep 2010 21:28:26 +0100 Subject: [PATCH 2/9] Tests for OPpENTERSUB_METHOD. Some of these fail, because the core isn't always careful enough about calling methods as methods. --- ext/XS-APItest/APItest.xs | 12 +++ ext/XS-APItest/t/methodcall.t | 218 +++++++++++++++++++++++++++++++++++++++++ 2 files changed, 230 insertions(+), 0 deletions(-) create mode 100644 ext/XS-APItest/t/methodcall.t diff --git a/ext/XS-APItest/APItest.xs b/ext/XS-APItest/APItest.xs index c6cac13..2c66b73 100644 --- a/ext/XS-APItest/APItest.xs +++ b/ext/XS-APItest/APItest.xs @@ -1118,6 +1118,18 @@ my_caller(level) XSRETURN(8); +bool +called_as_method(level) + I32 level + PREINIT: + const PERL_CONTEXT *cx; + CODE: + cx = caller_cx(level, NULL); + RETVAL = cx->blk_u16 & OPpENTERSUB_METHOD; + OUTPUT: + RETVAL + + void DPeek (sv) SV *sv diff --git a/ext/XS-APItest/t/methodcall.t b/ext/XS-APItest/t/methodcall.t new file mode 100644 index 0000000..d433a99 --- /dev/null +++ b/ext/XS-APItest/t/methodcall.t @@ -0,0 +1,218 @@ +#!/usr/bin/perl + +use warnings; +use strict; + +use XS::APItest; +use Test::More; + +my $was_meth; +{ + my $count = 0; + + sub was_meth { + my ($name) = @_; + my $B = Test::More->builder; + if ($count == 1) { + $B->ok($was_meth, $name); + } + else { + $B->ok(0, $name); + $B->diag("set_was_meth called $count times, not 1"); + } + $was_meth = undef; + $count = 0; + } + sub wasnt_meth { + $was_meth = !$was_meth; + was_meth @_; + } + sub set_was_meth { + $was_meth = XS::APItest::called_as_method(1); + $count++; + } +} + +sub as_meth { set_was_meth } + +for my $with (qw/no use/) { + eval <<PERL; +$with strict; + +as_meth(); +wasnt_meth "function call ($with strict)"; + +main->as_meth; +was_meth "class method call ($with strict)"; + +my \$obj = bless [], "main"; +\$obj->as_meth; +was_meth "object method call ($with strict)"; + +my \$meth = \\&as_meth; +\$meth->(); +wasnt_meth "indirect function call ($with strict)"; + +main->\$meth; +was_meth "indirect class method call ($with strict)"; + +\$obj->\$meth; +was_meth "indirect object method call ($with strict)"; +PERL +} + +sub tail { goto &as_meth } + +tail; +wasnt_meth "function tailcall"; + +main->tail; +was_meth "method tailcall"; + +{ + local *AUTOLOAD; + *AUTOLOAD = \&as_meth; + + foobar(); + wasnt_meth "AUTOLOADed function call"; + + main->foobar; + was_meth "AUTOLOADed method call"; +} + +sub TIEHASH { + set_was_meth; + return bless []; +} + +tie my %x, "main"; +was_meth "TIEHASH method call"; + +sub FETCH { set_was_meth; return 1 } +my $dummy = $x{foo}; +was_meth "FETCH (real magic) method call"; + +sub EXISTS { + set_was_meth; + return; +} +$dummy = exists $x{foo}; +was_meth "EXISTS (fake magic) method call"; + +sub UNTIE { set_was_meth } +untie %x; +was_meth "UNTIE method call"; + +use overload q/-/ => "as_meth", q/+/ => \&as_meth; +my $obj = bless []; + +$dummy = 0 + $obj; +wasnt_meth "overloaded function call"; + +TODO: { + local $TODO = "overloaded method calls"; + + $dummy = 0 - $obj; + was_meth "overloaded method call"; +} + +$INC{"Import.pm"} = $0; +sub Import::import { set_was_meth } +eval "use Import;"; +was_meth "import method"; + +$INC{"Version.pm"} = $0; +sub Version::VERSION { set_was_meth } +eval "use Version 1.00;"; +was_meth "VERSION method"; + +sub Destroy::DESTROY { set_was_meth } +{ bless [], "Destroy" } +was_meth "DESTROY method"; + +sub Exception::PROPAGATE { + set_was_meth; + return "Oops!"; +} +eval { + eval { die bless [], "Exception" }; + die; +}; +was_meth "PROPAGATE method call"; + +eval q{ + package Attrib; + sub MODIFY_SCALAR_ATTRIBUTES { + main::set_was_meth; + return; + } + our $x : Foo; +}; +was_meth "our attribute MODIFY method call"; + +{ + package Attrib; + my $y : Foo; +} +was_meth "my attribute MODIFY method call"; + +{ + package Attrib; + my $z : Foo = 1; +} +was_meth "my-with-assign attribute MODIFY method call"; + +eval q{ + package Attrib; + BEGIN { *MODIFY_CODE_ATTRIBUTES = \&MODIFY_SCALAR_ATTRIBUTES }; + BEGIN { *MODIFY_CODE_ATTRIBUTES = \&MODIFY_SCALAR_ATTRIBUTES }; + sub foo : Foo { } +}; +was_meth "sub attribute MODIFY method call"; + +{ + package Attrib; + *FETCH_CODE_ATTRIBUTES = \&MODIFY_CODE_ATTRIBUTES; + *FETCH_CODE_ATTRIBUTES = \&MODIFY_CODE_ATTRIBUTES; + attributes::get \&foo; +} +was_meth "attribute FETCH method call"; + +{ + package Cloner; + sub CLONE { main::set_was_meth } + sub CLONE_SKIP { main::set_was_meth; 0; } +} + +require threads; +$dummy = $threads::threads; # SHUT UP +if ($threads::threads) { + my $thr = threads->new(sub { $was_meth }); + was_meth "CLONE_SKIP method call"; + + my $twm = $thr->join; + ok $twm, "CLONE method call"; +} + +call_sv \&as_meth, G_VOID; +wasnt_meth "call_sv function ref call"; + +{ + no strict; + call_sv "as_meth", G_VOID; + wasnt_meth "call_sv function symref call"; +} + +call_sv *as_meth, G_VOID; +wasnt_meth "call_sv function glob call"; + +call_method "as_meth", G_VOID, "main"; +was_meth "call_method class method call"; + +call_method "as_meth", G_VOID, $obj; +was_meth "call_method object method call"; + +call_sv \&as_meth, G_VOID|G_METHOD, "main"; +was_meth "call_sv method call"; + +done_testing; -- 1.7.1.1
From 7b1c7d7fdde6ac2558ee1ec1d7e8d90f9e4b49b5 Mon Sep 17 00:00:00 2001 From: Ben Morrow <ben@morrow.me.uk> Date: Mon, 20 Sep 2010 21:12:22 +0100 Subject: [PATCH 3/9] Make all the magic method calls method calls. Specifically PROPAGATE, UNTIE, DESTROY, CLONE and CLONE_SKIP. --- pp_sys.c | 4 ++-- sv.c | 6 +++--- 2 files changed, 5 insertions(+), 5 deletions(-) diff --git a/pp_sys.c b/pp_sys.c index 0dcca28..120c55e 100644 --- a/pp_sys.c +++ b/pp_sys.c @@ -475,7 +475,7 @@ PP(pp_die) PUSHs(line); PUTBACK; call_sv(MUTABLE_SV(GvCV(gv)), - G_SCALAR|G_EVAL|G_KEEPERR); + G_SCALAR|G_EVAL|G_KEEPERR|G_FAKINGMETH); exsv = sv_mortalcopy(*PL_stack_sp--); } } @@ -916,7 +916,7 @@ PP(pp_untie) mXPUSHi(SvREFCNT(obj) - 1); PUTBACK; ENTER_with_name("call_UNTIE"); - call_sv(MUTABLE_SV(cv), G_VOID); + call_sv(MUTABLE_SV(cv), G_VOID|G_FAKINGMETH); LEAVE_with_name("call_UNTIE"); SPAGAIN; } diff --git a/sv.c b/sv.c index 0c78725..222abb5 100644 --- a/sv.c +++ b/sv.c @@ -5793,7 +5793,7 @@ Perl_sv_clear(pTHX_ register SV *const sv) PUSHMARK(SP); PUSHs(tmpref); PUTBACK; - call_sv(MUTABLE_SV(destructor), G_DISCARD|G_EVAL|G_KEEPERR|G_VOID); + call_sv(MUTABLE_SV(destructor), G_DISCARD|G_EVAL|G_KEEPERR|G_VOID|G_FAKINGMETH); POPSTACK; @@ -12042,7 +12042,7 @@ do_mark_cloneable_stash(pTHX_ SV *const sv) PUSHMARK(SP); mXPUSHs(newSVhek(hvname)); PUTBACK; - call_sv(MUTABLE_SV(GvCV(cloner)), G_SCALAR); + call_sv(MUTABLE_SV(GvCV(cloner)), G_SCALAR|G_FAKINGMETH); SPAGAIN; status = POPu; PUTBACK; @@ -12792,7 +12792,7 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, PUSHMARK(SP); mXPUSHs(newSVhek(HvNAME_HEK(stash))); PUTBACK; - call_sv(MUTABLE_SV(GvCV(cloner)), G_DISCARD); + call_sv(MUTABLE_SV(GvCV(cloner)), G_DISCARD|G_FAKINGMETH); FREETMPS; LEAVE; } -- 1.7.1.1
From 4434c1b543de468f8e7ac3450656cec7caeb75fb Mon Sep 17 00:00:00 2001 From: Ben Morrow <ben@morrow.me.uk> Date: Sun, 19 Sep 2010 20:02:22 +0100 Subject: [PATCH 4/9] Fix attribute method calls to be method calls. --- ext/attributes/attributes.pm | 4 ++-- 1 files changed, 2 insertions(+), 2 deletions(-) diff --git a/ext/attributes/attributes.pm b/ext/attributes/attributes.pm index c117bef..8d4a2d0 100644 --- a/ext/attributes/attributes.pm +++ b/ext/attributes/attributes.pm @@ -52,7 +52,7 @@ sub import { my @badattrs; if ($pkgmeth) { my @pkgattrs = _modify_attrs_and_deprecate($svtype, $svref, @attrs); - @badattrs = $pkgmeth->($home_stash, $svref, @pkgattrs); + @badattrs = $home_stash->$pkgmeth($svref, @pkgattrs); if (!@badattrs && @pkgattrs) { require warnings; return unless warnings::enabled('reserved'); @@ -90,7 +90,7 @@ sub get ($) { $pkgmeth = UNIVERSAL::can($stash, "FETCH_${svtype}_ATTRIBUTES") if defined $stash && $stash ne ''; return $pkgmeth ? - (_fetch_attrs($svref), $pkgmeth->($stash, $svref)) : + (_fetch_attrs($svref), $stash->$pkgmeth($svref)) : (_fetch_attrs($svref)) ; } -- 1.7.1.1
From 9f49ca97e5757c414838a803a8aaeeb6318062bd Mon Sep 17 00:00:00 2001 From: Ben Morrow <ben@morrow.me.uk> Date: Mon, 20 Sep 2010 19:47:23 +0100 Subject: [PATCH 5/9] Tell the debugger about method calls. Whenever $DB::sub gets set, also set $DB::method to indicate whether this was a function or a method call. --- embed.fnc | 2 +- intrpvar.h | 5 +++++ perl.c | 4 ++++ pp_ctl.c | 3 ++- pp_hot.c | 3 ++- sv.c | 1 + util.c | 5 ++++- 7 files changed, 19 insertions(+), 4 deletions(-) diff --git a/embed.fnc b/embed.fnc index 71e6e1c..7f3479e 100644 --- a/embed.fnc +++ b/embed.fnc @@ -418,7 +418,7 @@ s |OP* |gen_constant_list|NULLOK OP* o p |char* |getenv_len |NN const char *env_elem|NN unsigned long *len #endif : Used in pp_ctl.c and pp_hot.c -pox |void |get_db_sub |NULLOK SV **svp|NN CV *cv +pox |void |get_db_sub |NULLOK SV **svp|NN CV *cv|const U32 flags Ap |void |gp_free |NULLOK GV* gv Ap |GP* |gp_ref |NULLOK GP* gp Ap |GV* |gv_add_by_type |NULLOK GV *gv|svtype type diff --git a/intrpvar.h b/intrpvar.h index 4a7d867..dfe07a2 100644 --- a/intrpvar.h +++ b/intrpvar.h @@ -360,6 +360,10 @@ Trace variable used when Perl is run in debugging mode, with the B<-d> switch. This is the C variable which corresponds to Perl's $DB::trace variable. See C<PL_DBsingle>. +=for apidoc mn|SV *|PL_DBmethod +When Perl is run in debugging mode, with the B<-d> switch, this indicates +whether a given call to C<&DB::sub> was for a function or a method. + =cut */ @@ -367,6 +371,7 @@ PERLVAR(IDBsub, GV *) /* *DB::sub */ PERLVAR(IDBsingle, SV *) /* $DB::single */ PERLVAR(IDBtrace, SV *) /* $DB::trace */ PERLVAR(IDBsignal, SV *) /* $DB::signal */ +PERLVAR(IDBmethod, SV *) /* $DB::method */ PERLVAR(Idbargs, AV *) /* args to call listed by caller function */ /* symbol tables */ diff --git a/perl.c b/perl.c index 6a64de0..5106275 100644 --- a/perl.c +++ b/perl.c @@ -954,6 +954,7 @@ perl_destruct(pTHXx) PL_DBsingle = NULL; PL_DBtrace = NULL; PL_DBsignal = NULL; + PL_DBmethod = NULL; PL_DBcv = NULL; PL_dbargs = NULL; PL_debstash = NULL; @@ -3826,6 +3827,9 @@ Perl_init_debugger(pTHX) PL_DBsignal = GvSV((gv_fetchpvs("DB::signal", GV_ADDMULTI, SVt_PV))); if (!SvIOK(PL_DBsignal)) sv_setiv(PL_DBsignal, 0); + PL_DBmethod = GvSV((gv_fetchpvs("DB::method", GV_ADDMULTI, SVt_PV))); + if (!SvOK(PL_DBmethod)) + sv_setsv(PL_DBmethod, &PL_sv_no); PL_curstash = ostash; } diff --git a/pp_ctl.c b/pp_ctl.c index 0a9dcfe..fbbbf1e 100644 --- a/pp_ctl.c +++ b/pp_ctl.c @@ -2643,7 +2643,8 @@ PP(pp_goto) } } if (PERLDB_SUB) { /* Checking curstash breaks DProf. */ - Perl_get_db_sub(aTHX_ NULL, cv); + Perl_get_db_sub(aTHX_ NULL, cv, + (cx->blk_u16 & OPpENTERSUB_METHOD)); if (PERLDB_GOTO) { CV * const gotocv = get_cvs("DB::goto", 0); if (gotocv) { diff --git a/pp_hot.c b/pp_hot.c index 4f043fb..ba76748 100644 --- a/pp_hot.c +++ b/pp_hot.c @@ -2832,7 +2832,8 @@ try_autoload: gimme = GIMME_V; if ((PL_op->op_private & OPpENTERSUB_DB) && GvCV(PL_DBsub) && !CvNODEBUG(cv)) { - Perl_get_db_sub(aTHX_ &sv, cv); + Perl_get_db_sub(aTHX_ &sv, cv, + (PL_op->op_private & OPpENTERSUB_METHOD)); if (CvISXSUB(cv)) PL_curcopdb = PL_curcop; if (CvLVALUE(cv)) { diff --git a/sv.c b/sv.c index 222abb5..3560aa2 100644 --- a/sv.c +++ b/sv.c @@ -12392,6 +12392,7 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, PL_DBsingle = sv_dup(proto_perl->IDBsingle, param); PL_DBtrace = sv_dup(proto_perl->IDBtrace, param); PL_DBsignal = sv_dup(proto_perl->IDBsignal, param); + PL_DBmethod = sv_dup(proto_perl->IDBmethod, param); /* symbol tables */ PL_defstash = hv_dup_inc(proto_perl->Idefstash, param); diff --git a/util.c b/util.c index 2ab14d7..b95976e 100644 --- a/util.c +++ b/util.c @@ -6483,7 +6483,7 @@ long _ftol2( double dblSource ) { return _ftol( dblSource ); } #endif void -Perl_get_db_sub(pTHX_ SV **svp, CV *cv) +Perl_get_db_sub(pTHX_ SV **svp, CV *cv, const U32 flags) { dVAR; SV * const dbsv = GvSVn(PL_DBsub); @@ -6497,6 +6497,9 @@ Perl_get_db_sub(pTHX_ SV **svp, CV *cv) PL_tainted = FALSE; save_item(dbsv); + save_item(PL_DBmethod); + sv_setsv(PL_DBmethod, + (flags & OPpENTERSUB_METHOD) ? &PL_sv_yes : &PL_sv_no); if (!PERLDB_SUB_NN) { GV * const gv = CvGV(cv); -- 1.7.1.1
From 36d2fbca462ec061a606696faa533f2e5125c3b0 Mon Sep 17 00:00:00 2001 From: Ben Morrow <ben@morrow.me.uk> Date: Mon, 20 Sep 2010 19:48:49 +0100 Subject: [PATCH 6/9] make regen. --- embedvar.h | 2 ++ proto.h | 2 +- 2 files changed, 3 insertions(+), 1 deletions(-) diff --git a/embedvar.h b/embedvar.h index 3a9bccc..074b81f 100644 --- a/embedvar.h +++ b/embedvar.h @@ -45,6 +45,7 @@ #define PL_DBcv (vTHX->IDBcv) #define PL_DBgv (vTHX->IDBgv) #define PL_DBline (vTHX->IDBline) +#define PL_DBmethod (vTHX->IDBmethod) #define PL_DBsignal (vTHX->IDBsignal) #define PL_DBsingle (vTHX->IDBsingle) #define PL_DBsub (vTHX->IDBsub) @@ -375,6 +376,7 @@ #define PL_IDBcv PL_DBcv #define PL_IDBgv PL_DBgv #define PL_IDBline PL_DBline +#define PL_IDBmethod PL_DBmethod #define PL_IDBsignal PL_DBsignal #define PL_IDBsingle PL_DBsingle #define PL_IDBsub PL_DBsub diff --git a/proto.h b/proto.h index 6b1e25b..5c5ee47 100644 --- a/proto.h +++ b/proto.h @@ -873,7 +873,7 @@ PERL_CALLCONV char* Perl_getenv_len(pTHX_ const char *env_elem, unsigned long *l assert(env_elem); assert(len) #endif -PERL_CALLCONV void Perl_get_db_sub(pTHX_ SV **svp, CV *cv) +PERL_CALLCONV void Perl_get_db_sub(pTHX_ SV **svp, CV *cv, const U32 flags) __attribute__nonnull__(pTHX_2); #define PERL_ARGS_ASSERT_GET_DB_SUB \ assert(cv) -- 1.7.1.1
From e2c33a60f7108cf7981b5a6bfee3d4065d293062 Mon Sep 17 00:00:00 2001 From: Ben Morrow <ben@morrow.me.uk> Date: Mon, 20 Sep 2010 21:29:08 +0100 Subject: [PATCH 7/9] Test $DB::method. --- ext/XS-APItest/t/methodcall.t | 24 ++++++++++++++++++++++++ 1 files changed, 24 insertions(+), 0 deletions(-) diff --git a/ext/XS-APItest/t/methodcall.t b/ext/XS-APItest/t/methodcall.t index d433a99..422efa8 100644 --- a/ext/XS-APItest/t/methodcall.t +++ b/ext/XS-APItest/t/methodcall.t @@ -194,6 +194,30 @@ if ($threads::threads) { ok $twm, "CLONE method call"; } +my $DB_meth; +{ + package DB; + sub sub { + $DB_meth = $DB::method; + no strict "refs"; + &$DB::sub; + } +} + +BEGIN { $^P = 1 } +as_meth; +BEGIN { $^P = 0 } + +wasnt_meth "function call under DB::sub"; +ok !$DB_meth, "...reported as function to &DB::sub"; + +BEGIN { $^P = 1 } +main->as_meth; +BEGIN { $^P = 0 } + +was_meth "method call under DB::sub"; +ok $DB_meth, "...reported as method to &DB::sub"; + call_sv \&as_meth, G_VOID; wasnt_meth "call_sv function ref call"; -- 1.7.1.1
From b28cbe9900935a3814ee2348380e61eddafe3596 Mon Sep 17 00:00:00 2001 From: Ben Morrow <ben@morrow.me.uk> Date: Tue, 21 Sep 2010 01:58:09 +0100 Subject: [PATCH 8/9] Update MANIFEST. --- MANIFEST | 1 + 1 files changed, 1 insertions(+), 0 deletions(-) diff --git a/MANIFEST b/MANIFEST index 3e9583a..6e3e51f 100644 --- a/MANIFEST +++ b/MANIFEST @@ -3336,6 +3336,7 @@ ext/XS-APItest/t/copyhints.t test hv_copy_hints_hv() API ext/XS-APItest/t/exception.t XS::APItest extension ext/XS-APItest/t/hash.t XS::APItest: tests for hash related APIs ext/XS-APItest/t/Markers.pm Helper for ./blockhooks.t +ext/XS-APItest/t/methodcall.t XS::APItest: test OPpENTERSUB_METHOD ext/XS-APItest/t/my_cxt.t XS::APItest: test MY_CXT interface ext/XS-APItest/t/my_exit.t XS::APItest: test my_exit ext/XS-APItest/t/Null.pm Helper for ./blockhooks.t -- 1.7.1.1
From 890c6121426dcdbdaa38781112cae6097900b32f Mon Sep 17 00:00:00 2001 From: Ben Morrow <ben@morrow.me.uk> Date: Tue, 21 Sep 2010 01:58:20 +0100 Subject: [PATCH 9/9] Fixup the tests in ext/B for OPpENTERSUB_METHOD. --- ext/B/t/f_map.t | 8 ++++---- ext/B/t/optree_samples.t | 8 ++++---- ext/B/t/optree_specials.t | 36 ++++++++++++++++++------------------ 3 files changed, 26 insertions(+), 26 deletions(-) diff --git a/ext/B/t/f_map.t b/ext/B/t/f_map.t index 11877ef..472b274 100644 --- a/ext/B/t/f_map.t +++ b/ext/B/t/f_map.t @@ -104,7 +104,7 @@ checkOptree(note => q{}, # b <0> pushmark s # c <#> gvsv[*_] s # d <#> gv[*getkey] s/EARLYCV -# e <1> entersub[t5] lKS/TARG,1 +# e <1> entersub[t5] lKS/TARG # f <#> gvsv[*_] s # g <@> list lK # h <@> leave lKP @@ -128,7 +128,7 @@ EOT_EOT # b <0> pushmark s # c <$> gvsv(*_) s # d <$> gv(*getkey) s/EARLYCV -# e <1> entersub[t2] lKS/TARG,1 +# e <1> entersub[t2] lKS/TARG # f <$> gvsv(*_) s # g <@> list lK # h <@> leave lKP @@ -180,7 +180,7 @@ checkOptree(note => q{}, # k <0> pushmark s # l <#> gvsv[*_] s # m <#> gv[*getkey] s/EARLYCV -# n <1> entersub[t10] sKS/TARG,1 +# n <1> entersub[t10] sKS/TARG # o <2> helem sKRM*/2 # p <2> sassign vKS/2 # q <0> unstack s @@ -213,7 +213,7 @@ EOT_EOT # k <0> pushmark s # l <$> gvsv(*_) s # m <$> gv(*getkey) s/EARLYCV -# n <1> entersub[t4] sKS/TARG,1 +# n <1> entersub[t4] sKS/TARG # o <2> helem sKRM*/2 # p <2> sassign vKS/2 # q <0> unstack s diff --git a/ext/B/t/optree_samples.t b/ext/B/t/optree_samples.t index 2a78972..f9cabbe 100644 --- a/ext/B/t/optree_samples.t +++ b/ext/B/t/optree_samples.t @@ -478,7 +478,7 @@ checkOptree ( name => '%h = map { getkey($_) => $_ } @a', # b <0> pushmark s # c <#> gvsv[*_] s # d <#> gv[*getkey] s/EARLYCV -# e <1> entersub[t5] lKS/TARG,1 +# e <1> entersub[t5] lKS/TARG # f <#> gvsv[*_] s # g <@> list lK # h <@> leave lKP @@ -502,7 +502,7 @@ EOT_EOT # b <0> pushmark s # c <$> gvsv(*_) s # d <$> gv(*getkey) s/EARLYCV -# e <1> entersub[t2] lKS/TARG,1 +# e <1> entersub[t2] lKS/TARG # f <$> gvsv(*_) s # g <@> list lK # h <@> leave lKP @@ -540,7 +540,7 @@ checkOptree ( name => '%h=(); for $_(@a){$h{getkey($_)} = $_}', # i <0> pushmark s # j <#> gvsv[*_] s # k <#> gv[*getkey] s/EARLYCV -# l <1> entersub[t10] sKS/TARG,1 +# l <1> entersub[t10] sKS/TARG # m <2> helem sKRM*/2 # n <2> sassign vKS/2 # o <0> unstack s @@ -570,7 +570,7 @@ EOT_EOT # i <0> pushmark s # j <$> gvsv(*_) s # k <$> gv(*getkey) s/EARLYCV -# l <1> entersub[t4] sKS/TARG,1 +# l <1> entersub[t4] sKS/TARG # m <2> helem sKRM*/2 # n <2> sassign vKS/2 # o <0> unstack s diff --git a/ext/B/t/optree_specials.t b/ext/B/t/optree_specials.t index 25f7335..bbad46b 100644 --- a/ext/B/t/optree_specials.t +++ b/ext/B/t/optree_specials.t @@ -56,7 +56,7 @@ checkOptree ( name => 'BEGIN', # 4 <;> nextstate(B::Concise -275 Concise.pm:356) v:*,&,{,$ ->5 # - <@> lineseq K ->- # - <0> null ->5 -# 9 <1> entersub[t1] KS*/TARG,2 ->a +# 9 <1> entersub[t1] KS*/METH,STRICT,TARG ->a # 5 <0> pushmark s ->6 # 6 <$> const[PV "strict"] sM ->7 # 7 <$> const[PV "refs"] sM ->8 @@ -70,7 +70,7 @@ checkOptree ( name => 'BEGIN', # e <;> nextstate(B::Concise -265 Concise.pm:367) v:*,&,$ ->f # - <@> lineseq K ->- # - <0> null ->f -# j <1> entersub[t1] KS*/TARG,2 ->k +# j <1> entersub[t1] KS*/METH,STRICT,TARG ->k # f <0> pushmark s ->g # g <$> const[PV "strict"] sM ->h # h <$> const[PV "refs"] sM ->i @@ -84,7 +84,7 @@ checkOptree ( name => 'BEGIN', # o <;> nextstate(B::Concise -254 Concise.pm:386) v:*,&,{,$ ->p # - <@> lineseq K ->- # - <0> null ->p -# t <1> entersub[t1] KS*/TARG,2 ->u +# t <1> entersub[t1] KS*/METH,STRICT,TARG ->u # p <0> pushmark s ->q # q <$> const[PV "warnings"] sM ->r # r <$> const[PV "qw"] sM ->s @@ -106,7 +106,7 @@ EOT_EOT # 4 <;> nextstate(B::Concise -275 Concise.pm:356) v:*,&,{,$ ->5 # - <@> lineseq K ->- # - <0> null ->5 -# 9 <1> entersub[t1] KS*/TARG,2 ->a +# 9 <1> entersub[t1] KS*/METH,STRICT,TARG ->a # 5 <0> pushmark s ->6 # 6 <$> const(PV "strict") sM ->7 # 7 <$> const(PV "refs") sM ->8 @@ -120,7 +120,7 @@ EOT_EOT # e <;> nextstate(B::Concise -265 Concise.pm:367) v:*,&,$ ->f # - <@> lineseq K ->- # - <0> null ->f -# j <1> entersub[t1] KS*/TARG,2 ->k +# j <1> entersub[t1] KS*/METH,STRICT,TARG ->k # f <0> pushmark s ->g # g <$> const(PV "strict") sM ->h # h <$> const(PV "refs") sM ->i @@ -134,7 +134,7 @@ EOT_EOT # o <;> nextstate(B::Concise -254 Concise.pm:386) v:*,&,{,$ ->p # - <@> lineseq K ->- # - <0> null ->p -# t <1> entersub[t1] KS*/TARG,2 ->u +# t <1> entersub[t1] KS*/METH,STRICT,TARG ->u # p <0> pushmark s ->q # q <$> const(PV "warnings") sM ->r # r <$> const(PV "qw") sM ->s @@ -257,7 +257,7 @@ checkOptree ( name => 'all of BEGIN END INIT CHECK UNITCHECK -exec', # 6 <$> const[PV "strict"] sM # 7 <$> const[PV "refs"] sM # 8 <$> method_named[PV "unimport"] -# 9 <1> entersub[t1] KS*/TARG,2 +# 9 <1> entersub[t1] KS*/METH,STRICT,TARG # a <1> leavesub[1 ref] K/REFC,1 # BEGIN 2: # b <;> nextstate(B::Concise -265 Concise.pm:367) v:*,&,$ @@ -268,7 +268,7 @@ checkOptree ( name => 'all of BEGIN END INIT CHECK UNITCHECK -exec', # g <$> const[PV "strict"] sM # h <$> const[PV "refs"] sM # i <$> method_named[PV "unimport"] -# j <1> entersub[t1] KS*/TARG,2 +# j <1> entersub[t1] KS*/METH,STRICT,TARG # k <1> leavesub[1 ref] K/REFC,1 # BEGIN 3: # l <;> nextstate(B::Concise -254 Concise.pm:386) v:*,&,{,$ @@ -279,7 +279,7 @@ checkOptree ( name => 'all of BEGIN END INIT CHECK UNITCHECK -exec', # q <$> const[PV "warnings"] sM # r <$> const[PV "qw"] sM # s <$> method_named[PV "unimport"] -# t <1> entersub[t1] KS*/TARG,2 +# t <1> entersub[t1] KS*/METH,STRICT,TARG # u <1> leavesub[1 ref] K/REFC,1 # BEGIN 4: # v <;> nextstate(main 2 -e:1) v:>,<,%,{ @@ -316,7 +316,7 @@ EOT_EOT # 6 <$> const(PV "strict") sM # 7 <$> const(PV "refs") sM # 8 <$> method_named(PV "unimport") -# 9 <1> entersub[t1] KS*/TARG,2 +# 9 <1> entersub[t1] KS*/METH,STRICT,TARG # a <1> leavesub[1 ref] K/REFC,1 # BEGIN 2: # b <;> nextstate(B::Concise -265 Concise.pm:367) v:*,&,$ @@ -327,7 +327,7 @@ EOT_EOT # g <$> const(PV "strict") sM # h <$> const(PV "refs") sM # i <$> method_named(PV "unimport") -# j <1> entersub[t1] KS*/TARG,2 +# j <1> entersub[t1] KS*/METH,STRICT,TARG # k <1> leavesub[1 ref] K/REFC,1 # BEGIN 3: # l <;> nextstate(B::Concise -254 Concise.pm:386) v:*,&,{,$ @@ -338,7 +338,7 @@ EOT_EOT # q <$> const(PV "warnings") sM # r <$> const(PV "qw") sM # s <$> method_named(PV "unimport") -# t <1> entersub[t1] KS*/TARG,2 +# t <1> entersub[t1] KS*/METH,STRICT,TARG # u <1> leavesub[1 ref] K/REFC,1 # BEGIN 4: # v <;> nextstate(main 2 -e:1) v:>,<,%,{ @@ -386,7 +386,7 @@ checkOptree ( name => 'regression test for patch 25352', # 6 <$> const[PV "strict"] sM # 7 <$> const[PV "refs"] sM # 8 <$> method_named[PV "unimport"] -# 9 <1> entersub[t1] KS*/TARG,2 +# 9 <1> entersub[t1] KS*/METH,STRICT,TARG # a <1> leavesub[1 ref] K/REFC,1 # BEGIN 2: # b <;> nextstate(B::Concise -265 Concise.pm:367) v:*,&,$ @@ -397,7 +397,7 @@ checkOptree ( name => 'regression test for patch 25352', # g <$> const[PV "strict"] sM # h <$> const[PV "refs"] sM # i <$> method_named[PV "unimport"] -# j <1> entersub[t1] KS*/TARG,2 +# j <1> entersub[t1] KS*/METH,STRICT,TARG # k <1> leavesub[1 ref] K/REFC,1 # BEGIN 3: # l <;> nextstate(B::Concise -254 Concise.pm:386) v:*,&,{,$ @@ -408,7 +408,7 @@ checkOptree ( name => 'regression test for patch 25352', # q <$> const[PV "warnings"] sM # r <$> const[PV "qw"] sM # s <$> method_named[PV "unimport"] -# t <1> entersub[t1] KS*/TARG,2 +# t <1> entersub[t1] KS*/METH,STRICT,TARG # u <1> leavesub[1 ref] K/REFC,1 EOT_EOT # BEGIN 1: @@ -420,7 +420,7 @@ EOT_EOT # 6 <$> const(PV "strict") sM # 7 <$> const(PV "refs") sM # 8 <$> method_named(PV "unimport") -# 9 <1> entersub[t1] KS*/TARG,2 +# 9 <1> entersub[t1] KS*/METH,STRICT,TARG # a <1> leavesub[1 ref] K/REFC,1 # BEGIN 2: # b <;> nextstate(B::Concise -265 Concise.pm:367) v:*,&,$ @@ -431,7 +431,7 @@ EOT_EOT # g <$> const(PV "strict") sM # h <$> const(PV "refs") sM # i <$> method_named(PV "unimport") -# j <1> entersub[t1] KS*/TARG,2 +# j <1> entersub[t1] KS*/METH,STRICT,TARG # k <1> leavesub[1 ref] K/REFC,1 # BEGIN 3: # l <;> nextstate(B::Concise -254 Concise.pm:386) v:*,&,{,$ @@ -442,6 +442,6 @@ EOT_EOT # q <$> const(PV "warnings") sM # r <$> const(PV "qw") sM # s <$> method_named(PV "unimport") -# t <1> entersub[t1] KS*/TARG,2 +# t <1> entersub[t1] KS*/METH,STRICT,TARG # u <1> leavesub[1 ref] K/REFC,1 EONT_EONT -- 1.7.1.1
Subject: Re: [perl #77974] [PATCH] Record method calls in the context stack
Date: Wed, 22 Sep 2010 11:48:28 +0100
To: perl5-porters [...] perl.org
From: Nicholas Clark <nick [...] ccl4.org>
Download (untitled) / with headers
text/plain 1.7k
On Tue, Sep 21, 2010 at 04:15:37PM -0700, Ben Morrow wrote: Show quoted text
> These patches record whether a given stack frame is for a function or a > method call, by adding a new OPpENTERSUB_PRIVATE bit. I need this for > PRE and POST blocks, which have different behaviour depending on whether > a sub is called as a method or not.
Aaargh. Attached patches make it easy (or easier) to do some things, but really damn hard to do others. I can't even reliably get a list of attachments. Anyway, what I wanted to say was that I'd not looked that the detail of the gubbins of this, but the way you've split it up (currently) is going to introduce intermediate states where tests fail. Which to my mind is bad, because 'git bisect' can end up hitting any of these intermediate states. I think that the "add the new file to the MANIFEST" patch should be part of the patch that creates the file. I think that the "some of these fail" comment in a test shouldn't be there, because the fixes to core functions to make them not fail should be earlier in the patch sequence. I see nothing wrong in having the change in to pass the extra flag bit, but nothing actually testing for it until a subsequent patch. Show quoted text
> I'm not entirely sure about the parts of this which touch B: it's in > ext/, so I presume it's not dual-life, but there seem to be lots of > dual-life-ish bits of code in there. I haven't made any attempt to > preserve compat with older perls; is this wrong?
Historically, when I was doing maint releases of 5.8.x, I was trying to keep one codebase, rather than forking B in maint-5.8 (and subsequently forking 3 ways for blead, maint-5.10 and maint-5.8). IIRC There was also a point when I was (mistakenly) assuming it was actually dual-lived, and being sufficiently defensive to cope with that. Nicholas Clark
Subject: Re: [perl #77974] [PATCH] Record method calls in the context stack
Date: Wed, 22 Sep 2010 12:20:43 +0100
To: nick [...] ccl4.org, perl5-porters [...] perl.org
From: Ben Morrow <ben [...] morrow.me.uk>
Download (untitled) / with headers
text/plain 2.4k
Quoth nick@ccl4.org (Nicholas Clark): Show quoted text
> On Tue, Sep 21, 2010 at 04:15:37PM -0700, Ben Morrow wrote: >
> > These patches record whether a given stack frame is for a function or a > > method call, by adding a new OPpENTERSUB_PRIVATE bit. I need this for > > PRE and POST blocks, which have different behaviour depending on whether > > a sub is called as a method or not.
> > Aaargh. Attached patches make it easy (or easier) to do some things, but > really damn hard to do others. I can't even reliably get a list of > attachments.
Is there anything I could have done differently that would make this easier? Pushed a branch to github? (My understanding was that it is easier to apply from a mail with am than to add a remote and pull from there... I suppose 'both' is always an option.) Show quoted text
> Anyway, what I wanted to say was that I'd not looked that the detail of > the gubbins of this, but the way you've split it up (currently) is going > to introduce intermediate states where tests fail. Which to my mind is bad, > because 'git bisect' can end up hitting any of these intermediate states. > > I think that the "add the new file to the MANIFEST" patch should be part of > the patch that creates the file. > > I think that the "some of these fail" comment in a test shouldn't be there, > because the fixes to core functions to make them not fail should be > earlier in the patch sequence. I see nothing wrong in having the change in > to pass the extra flag bit, but nothing actually testing for it until a > subsequent patch.
OK, makes sense. I'll resubmit when I've had a chance to rebase into the new order and run make test on each commit to make sure. If anyone feels like taking a more detailed look in the meanwhile, the code changes will be the same. Show quoted text
> > I'm not entirely sure about the parts of this which touch B: it's in > > ext/, so I presume it's not dual-life, but there seem to be lots of > > dual-life-ish bits of code in there. I haven't made any attempt to > > preserve compat with older perls; is this wrong?
> > Historically, when I was doing maint releases of 5.8.x, I was trying to keep > one codebase, rather than forking B in maint-5.8 (and subsequently forking > 3 ways for blead, maint-5.10 and maint-5.8). IIRC There was also a point > when I was (mistakenly) assuming it was actually dual-lived, and being > sufficiently defensive to cope with that.
So, given the current maint policy (i.e. there's no chance of this going into any maint), I don't need to worry about it? Ben
Subject: Re: [perl #77974] [PATCH] Record method calls in the context stack
Date: Thu, 23 Sep 2010 09:04:10 +0100
To: perlbug-followup [...] perl.org
From: Ben Morrow <ben [...] morrow.me.uk>
Download (untitled) / with headers
text/plain 1.4k
At 12PM +0100 on 22/09/10 I wrote: Show quoted text
> Quoth nick@ccl4.org (Nicholas Clark):
> > On Tue, Sep 21, 2010 at 04:15:37PM -0700, Ben Morrow wrote: > >
> > > These patches record whether a given stack frame is for a function or a > > > method call, by adding a new OPpENTERSUB_PRIVATE bit. I need this for > > > PRE and POST blocks, which have different behaviour depending on whether > > > a sub is called as a method or not.
>
> > Anyway, what I wanted to say was that I'd not looked that the detail of > > the gubbins of this, but the way you've split it up (currently) is going > > to introduce intermediate states where tests fail. Which to my mind is bad, > > because 'git bisect' can end up hitting any of these intermediate states. > > > > I think that the "add the new file to the MANIFEST" patch should be part of > > the patch that creates the file. > > > > I think that the "some of these fail" comment in a test shouldn't be there, > > because the fixes to core functions to make them not fail should be > > earlier in the patch sequence. I see nothing wrong in having the change in > > to pass the extra flag bit, but nothing actually testing for it until a > > subsequent patch.
> > OK, makes sense. I'll resubmit when I've had a chance to rebase into the > new order and run make test on each commit to make sure. If anyone feels > like taking a more detailed look in the meanwhile, the code changes will > be the same.
Attached. Ben
From 223edfe3940206f6655abef734a3d945b9d6bcbe Mon Sep 17 00:00:00 2001 From: Ben Morrow <ben@morrow.me.uk> Date: Sat, 18 Sep 2010 18:56:57 +0100 Subject: [PATCH 1/6] Record method calls in the context stack. This requires a new private flag for OP_ENTERSUB, OPpENTERSUB_METHOD, which gets copied into the ->blk_u16 member of the context structure. Since this changes the B::Concise output, this commit also updates those tests. --- cop.h | 2 +- ext/B/B/Concise.pm | 2 +- ext/B/t/f_map.t | 8 ++++---- ext/B/t/optree_samples.t | 8 ++++---- ext/B/t/optree_specials.t | 36 ++++++++++++++++++------------------ op.c | 1 + op.h | 4 +++- perl.c | 1 + 8 files changed, 33 insertions(+), 29 deletions(-) diff --git a/cop.h b/cop.h index 4791c80..c742485 100644 --- a/cop.h +++ b/cop.h @@ -337,7 +337,7 @@ struct block_format { #define PUSHSUB(cx) \ PUSHSUB_BASE(cx) \ cx->blk_u16 = PL_op->op_private & \ - (OPpLVAL_INTRO|OPpENTERSUB_INARGS); + (OPpENTERSUB_METHOD|OPpLVAL_INTRO|OPpENTERSUB_INARGS); /* variant for use by OP_DBSTATE, where op_private holds hint bits */ #define PUSHSUB_DB(cx) \ diff --git a/ext/B/B/Concise.pm b/ext/B/B/Concise.pm index 53afe83..96de5b9 100644 --- a/ext/B/B/Concise.pm +++ b/ext/B/B/Concise.pm @@ -610,7 +610,7 @@ $priv{$_}{4} = "DREFed" for (qw(rv2sv rv2av rv2hv)); @{$priv{$_}}{32,64,96} = ("DREFAV", "DREFHV", "DREFSV") for (qw(rv2gv rv2sv padsv aelem helem)); $priv{$_}{16} = "STATE" for ("padav", "padhv", "padsv"); -@{$priv{"entersub"}}{16,32,64} = ("DBG","TARG","NOMOD"); +@{$priv{"entersub"}}{1,2,16,32,64} = ("TARG","STRICT","DBG","METH","NOMOD"); @{$priv{$_}}{4,8,128} = ("INARGS","AMPER","NO()") for ("entersub", "rv2cv"); $priv{"gv"}{32} = "EARLYCV"; $priv{"aelem"}{16} = $priv{"helem"}{16} = "LVDEFER"; diff --git a/ext/B/t/f_map.t b/ext/B/t/f_map.t index 11877ef..472b274 100644 --- a/ext/B/t/f_map.t +++ b/ext/B/t/f_map.t @@ -104,7 +104,7 @@ checkOptree(note => q{}, # b <0> pushmark s # c <#> gvsv[*_] s # d <#> gv[*getkey] s/EARLYCV -# e <1> entersub[t5] lKS/TARG,1 +# e <1> entersub[t5] lKS/TARG # f <#> gvsv[*_] s # g <@> list lK # h <@> leave lKP @@ -128,7 +128,7 @@ EOT_EOT # b <0> pushmark s # c <$> gvsv(*_) s # d <$> gv(*getkey) s/EARLYCV -# e <1> entersub[t2] lKS/TARG,1 +# e <1> entersub[t2] lKS/TARG # f <$> gvsv(*_) s # g <@> list lK # h <@> leave lKP @@ -180,7 +180,7 @@ checkOptree(note => q{}, # k <0> pushmark s # l <#> gvsv[*_] s # m <#> gv[*getkey] s/EARLYCV -# n <1> entersub[t10] sKS/TARG,1 +# n <1> entersub[t10] sKS/TARG # o <2> helem sKRM*/2 # p <2> sassign vKS/2 # q <0> unstack s @@ -213,7 +213,7 @@ EOT_EOT # k <0> pushmark s # l <$> gvsv(*_) s # m <$> gv(*getkey) s/EARLYCV -# n <1> entersub[t4] sKS/TARG,1 +# n <1> entersub[t4] sKS/TARG # o <2> helem sKRM*/2 # p <2> sassign vKS/2 # q <0> unstack s diff --git a/ext/B/t/optree_samples.t b/ext/B/t/optree_samples.t index 2a78972..f9cabbe 100644 --- a/ext/B/t/optree_samples.t +++ b/ext/B/t/optree_samples.t @@ -478,7 +478,7 @@ checkOptree ( name => '%h = map { getkey($_) => $_ } @a', # b <0> pushmark s # c <#> gvsv[*_] s # d <#> gv[*getkey] s/EARLYCV -# e <1> entersub[t5] lKS/TARG,1 +# e <1> entersub[t5] lKS/TARG # f <#> gvsv[*_] s # g <@> list lK # h <@> leave lKP @@ -502,7 +502,7 @@ EOT_EOT # b <0> pushmark s # c <$> gvsv(*_) s # d <$> gv(*getkey) s/EARLYCV -# e <1> entersub[t2] lKS/TARG,1 +# e <1> entersub[t2] lKS/TARG # f <$> gvsv(*_) s # g <@> list lK # h <@> leave lKP @@ -540,7 +540,7 @@ checkOptree ( name => '%h=(); for $_(@a){$h{getkey($_)} = $_}', # i <0> pushmark s # j <#> gvsv[*_] s # k <#> gv[*getkey] s/EARLYCV -# l <1> entersub[t10] sKS/TARG,1 +# l <1> entersub[t10] sKS/TARG # m <2> helem sKRM*/2 # n <2> sassign vKS/2 # o <0> unstack s @@ -570,7 +570,7 @@ EOT_EOT # i <0> pushmark s # j <$> gvsv(*_) s # k <$> gv(*getkey) s/EARLYCV -# l <1> entersub[t4] sKS/TARG,1 +# l <1> entersub[t4] sKS/TARG # m <2> helem sKRM*/2 # n <2> sassign vKS/2 # o <0> unstack s diff --git a/ext/B/t/optree_specials.t b/ext/B/t/optree_specials.t index 25f7335..bbad46b 100644 --- a/ext/B/t/optree_specials.t +++ b/ext/B/t/optree_specials.t @@ -56,7 +56,7 @@ checkOptree ( name => 'BEGIN', # 4 <;> nextstate(B::Concise -275 Concise.pm:356) v:*,&,{,$ ->5 # - <@> lineseq K ->- # - <0> null ->5 -# 9 <1> entersub[t1] KS*/TARG,2 ->a +# 9 <1> entersub[t1] KS*/METH,STRICT,TARG ->a # 5 <0> pushmark s ->6 # 6 <$> const[PV "strict"] sM ->7 # 7 <$> const[PV "refs"] sM ->8 @@ -70,7 +70,7 @@ checkOptree ( name => 'BEGIN', # e <;> nextstate(B::Concise -265 Concise.pm:367) v:*,&,$ ->f # - <@> lineseq K ->- # - <0> null ->f -# j <1> entersub[t1] KS*/TARG,2 ->k +# j <1> entersub[t1] KS*/METH,STRICT,TARG ->k # f <0> pushmark s ->g # g <$> const[PV "strict"] sM ->h # h <$> const[PV "refs"] sM ->i @@ -84,7 +84,7 @@ checkOptree ( name => 'BEGIN', # o <;> nextstate(B::Concise -254 Concise.pm:386) v:*,&,{,$ ->p # - <@> lineseq K ->- # - <0> null ->p -# t <1> entersub[t1] KS*/TARG,2 ->u +# t <1> entersub[t1] KS*/METH,STRICT,TARG ->u # p <0> pushmark s ->q # q <$> const[PV "warnings"] sM ->r # r <$> const[PV "qw"] sM ->s @@ -106,7 +106,7 @@ EOT_EOT # 4 <;> nextstate(B::Concise -275 Concise.pm:356) v:*,&,{,$ ->5 # - <@> lineseq K ->- # - <0> null ->5 -# 9 <1> entersub[t1] KS*/TARG,2 ->a +# 9 <1> entersub[t1] KS*/METH,STRICT,TARG ->a # 5 <0> pushmark s ->6 # 6 <$> const(PV "strict") sM ->7 # 7 <$> const(PV "refs") sM ->8 @@ -120,7 +120,7 @@ EOT_EOT # e <;> nextstate(B::Concise -265 Concise.pm:367) v:*,&,$ ->f # - <@> lineseq K ->- # - <0> null ->f -# j <1> entersub[t1] KS*/TARG,2 ->k +# j <1> entersub[t1] KS*/METH,STRICT,TARG ->k # f <0> pushmark s ->g # g <$> const(PV "strict") sM ->h # h <$> const(PV "refs") sM ->i @@ -134,7 +134,7 @@ EOT_EOT # o <;> nextstate(B::Concise -254 Concise.pm:386) v:*,&,{,$ ->p # - <@> lineseq K ->- # - <0> null ->p -# t <1> entersub[t1] KS*/TARG,2 ->u +# t <1> entersub[t1] KS*/METH,STRICT,TARG ->u # p <0> pushmark s ->q # q <$> const(PV "warnings") sM ->r # r <$> const(PV "qw") sM ->s @@ -257,7 +257,7 @@ checkOptree ( name => 'all of BEGIN END INIT CHECK UNITCHECK -exec', # 6 <$> const[PV "strict"] sM # 7 <$> const[PV "refs"] sM # 8 <$> method_named[PV "unimport"] -# 9 <1> entersub[t1] KS*/TARG,2 +# 9 <1> entersub[t1] KS*/METH,STRICT,TARG # a <1> leavesub[1 ref] K/REFC,1 # BEGIN 2: # b <;> nextstate(B::Concise -265 Concise.pm:367) v:*,&,$ @@ -268,7 +268,7 @@ checkOptree ( name => 'all of BEGIN END INIT CHECK UNITCHECK -exec', # g <$> const[PV "strict"] sM # h <$> const[PV "refs"] sM # i <$> method_named[PV "unimport"] -# j <1> entersub[t1] KS*/TARG,2 +# j <1> entersub[t1] KS*/METH,STRICT,TARG # k <1> leavesub[1 ref] K/REFC,1 # BEGIN 3: # l <;> nextstate(B::Concise -254 Concise.pm:386) v:*,&,{,$ @@ -279,7 +279,7 @@ checkOptree ( name => 'all of BEGIN END INIT CHECK UNITCHECK -exec', # q <$> const[PV "warnings"] sM # r <$> const[PV "qw"] sM # s <$> method_named[PV "unimport"] -# t <1> entersub[t1] KS*/TARG,2 +# t <1> entersub[t1] KS*/METH,STRICT,TARG # u <1> leavesub[1 ref] K/REFC,1 # BEGIN 4: # v <;> nextstate(main 2 -e:1) v:>,<,%,{ @@ -316,7 +316,7 @@ EOT_EOT # 6 <$> const(PV "strict") sM # 7 <$> const(PV "refs") sM # 8 <$> method_named(PV "unimport") -# 9 <1> entersub[t1] KS*/TARG,2 +# 9 <1> entersub[t1] KS*/METH,STRICT,TARG # a <1> leavesub[1 ref] K/REFC,1 # BEGIN 2: # b <;> nextstate(B::Concise -265 Concise.pm:367) v:*,&,$ @@ -327,7 +327,7 @@ EOT_EOT # g <$> const(PV "strict") sM # h <$> const(PV "refs") sM # i <$> method_named(PV "unimport") -# j <1> entersub[t1] KS*/TARG,2 +# j <1> entersub[t1] KS*/METH,STRICT,TARG # k <1> leavesub[1 ref] K/REFC,1 # BEGIN 3: # l <;> nextstate(B::Concise -254 Concise.pm:386) v:*,&,{,$ @@ -338,7 +338,7 @@ EOT_EOT # q <$> const(PV "warnings") sM # r <$> const(PV "qw") sM # s <$> method_named(PV "unimport") -# t <1> entersub[t1] KS*/TARG,2 +# t <1> entersub[t1] KS*/METH,STRICT,TARG # u <1> leavesub[1 ref] K/REFC,1 # BEGIN 4: # v <;> nextstate(main 2 -e:1) v:>,<,%,{ @@ -386,7 +386,7 @@ checkOptree ( name => 'regression test for patch 25352', # 6 <$> const[PV "strict"] sM # 7 <$> const[PV "refs"] sM # 8 <$> method_named[PV "unimport"] -# 9 <1> entersub[t1] KS*/TARG,2 +# 9 <1> entersub[t1] KS*/METH,STRICT,TARG # a <1> leavesub[1 ref] K/REFC,1 # BEGIN 2: # b <;> nextstate(B::Concise -265 Concise.pm:367) v:*,&,$ @@ -397,7 +397,7 @@ checkOptree ( name => 'regression test for patch 25352', # g <$> const[PV "strict"] sM # h <$> const[PV "refs"] sM # i <$> method_named[PV "unimport"] -# j <1> entersub[t1] KS*/TARG,2 +# j <1> entersub[t1] KS*/METH,STRICT,TARG # k <1> leavesub[1 ref] K/REFC,1 # BEGIN 3: # l <;> nextstate(B::Concise -254 Concise.pm:386) v:*,&,{,$ @@ -408,7 +408,7 @@ checkOptree ( name => 'regression test for patch 25352', # q <$> const[PV "warnings"] sM # r <$> const[PV "qw"] sM # s <$> method_named[PV "unimport"] -# t <1> entersub[t1] KS*/TARG,2 +# t <1> entersub[t1] KS*/METH,STRICT,TARG # u <1> leavesub[1 ref] K/REFC,1 EOT_EOT # BEGIN 1: @@ -420,7 +420,7 @@ EOT_EOT # 6 <$> const(PV "strict") sM # 7 <$> const(PV "refs") sM # 8 <$> method_named(PV "unimport") -# 9 <1> entersub[t1] KS*/TARG,2 +# 9 <1> entersub[t1] KS*/METH,STRICT,TARG # a <1> leavesub[1 ref] K/REFC,1 # BEGIN 2: # b <;> nextstate(B::Concise -265 Concise.pm:367) v:*,&,$ @@ -431,7 +431,7 @@ EOT_EOT # g <$> const(PV "strict") sM # h <$> const(PV "refs") sM # i <$> method_named(PV "unimport") -# j <1> entersub[t1] KS*/TARG,2 +# j <1> entersub[t1] KS*/METH,STRICT,TARG # k <1> leavesub[1 ref] K/REFC,1 # BEGIN 3: # l <;> nextstate(B::Concise -254 Concise.pm:386) v:*,&,{,$ @@ -442,6 +442,6 @@ EOT_EOT # q <$> const(PV "warnings") sM # r <$> const(PV "qw") sM # s <$> method_named(PV "unimport") -# t <1> entersub[t1] KS*/TARG,2 +# t <1> entersub[t1] KS*/METH,STRICT,TARG # u <1> leavesub[1 ref] K/REFC,1 EONT_EONT diff --git a/op.c b/op.c index db91cdb..8e4eac5 100644 --- a/op.c +++ b/op.c @@ -8449,6 +8449,7 @@ Perl_ck_subr(pTHX_ OP *o) } } else if (cvop->op_type == OP_METHOD || cvop->op_type == OP_METHOD_NAMED) { + o->op_private |= OPpENTERSUB_METHOD; if (o2->op_type == OP_CONST) o2->op_private &= ~OPpCONST_STRICT; else if (o2->op_type == OP_LIST) { diff --git a/op.h b/op.h index da280b8..2c0784c 100644 --- a/op.h +++ b/op.h @@ -200,8 +200,10 @@ Deprecated. Use C<GIMME_V> instead. #define OPpDEREFed 4 /* prev op was OPpDEREF */ /* OP_ENTERSUB only */ #define OPpENTERSUB_DB 16 /* Debug subroutine. */ -#define OPpENTERSUB_HASTARG 32 /* Called from OP tree. */ +#define OPpENTERSUB_HASTARG 1 /* Called from OP tree. */ #define OPpENTERSUB_NOMOD 64 /* Immune to mod() for :attrlist. */ +#define OPpENTERSUB_METHOD 32 /* This is a method call */ +/* OP_ENTERSUB also uses HINT_STRICT_REFS (= 2) */ /* OP_ENTERSUB and OP_RV2CV only */ #define OPpENTERSUB_AMPER 8 /* Used & form to call. */ #define OPpENTERSUB_NOPAREN 128 /* bare sub call (without parens) */ diff --git a/perl.c b/perl.c index cf42087..1bd2c46 100644 --- a/perl.c +++ b/perl.c @@ -2594,6 +2594,7 @@ Perl_call_sv(pTHX_ SV *sv, VOL I32 flags) method_op.op_type = OP_METHOD; myop.op_ppaddr = PL_ppaddr[OP_ENTERSUB]; myop.op_type = OP_ENTERSUB; + myop.op_private |= OPpENTERSUB_METHOD; PL_op = (OP*)&method_op; } -- 1.7.1.1
From 73f62fe799f7c2f3212b4e9e10ab5f53b5644ab7 Mon Sep 17 00:00:00 2001 From: Ben Morrow <ben@morrow.me.uk> Date: Mon, 20 Sep 2010 21:12:22 +0100 Subject: [PATCH 2/6] Make all the magic method calls method calls. Some core method calls are actually made as function calls, with an explicit lookup of the method to call beforehand (that is, as the C equivalent of my $meth = $obj->can("whatever"); $meth->($obj, @args); ). In order to ensure these are properly marked as method calls, we need a new G_FAKINGMETH flag to call_*. It would probably be cleaner to make them proper method calls; that is, the C equivalent of my $meth = $obj->can("whatever"); $obj->$meth(@args); but for now I'll leave them as they are. --- cop.h | 2 ++ perl.c | 4 ++++ pp_sys.c | 6 +++--- sv.c | 6 +++--- 4 files changed, 12 insertions(+), 6 deletions(-) diff --git a/cop.h b/cop.h index c742485..dd90d5b 100644 --- a/cop.h +++ b/cop.h @@ -766,6 +766,8 @@ L<perlcall>. #define G_UNDEF_FILL 512 /* Fill the stack with &PL_sv_undef A special case for UNSHIFT in Perl_magic_methcall(). */ +#define G_FAKINGMETH 1024 /* Faking a method call (we've already + done the lookup) */ /* flag bits for PL_in_eval */ #define EVAL_NULL 0 /* not in an eval */ diff --git a/perl.c b/perl.c index 1bd2c46..6a64de0 100644 --- a/perl.c +++ b/perl.c @@ -2598,6 +2598,10 @@ Perl_call_sv(pTHX_ SV *sv, VOL I32 flags) PL_op = (OP*)&method_op; } + if (flags & G_FAKINGMETH) { + myop.op_private |= OPpENTERSUB_METHOD; + } + if (!(flags & G_EVAL)) { CATCH_SET(TRUE); CALL_BODY_SUB((OP*)&myop); diff --git a/pp_sys.c b/pp_sys.c index 1bc072d..120c55e 100644 --- a/pp_sys.c +++ b/pp_sys.c @@ -475,7 +475,7 @@ PP(pp_die) PUSHs(line); PUTBACK; call_sv(MUTABLE_SV(GvCV(gv)), - G_SCALAR|G_EVAL|G_KEEPERR); + G_SCALAR|G_EVAL|G_KEEPERR|G_FAKINGMETH); exsv = sv_mortalcopy(*PL_stack_sp--); } } @@ -872,7 +872,7 @@ PP(pp_tie) while (items--) PUSHs(*MARK++); PUTBACK; - call_sv(MUTABLE_SV(GvCV(gv)), G_SCALAR); + call_sv(MUTABLE_SV(GvCV(gv)), G_SCALAR|G_FAKINGMETH); } SPAGAIN; @@ -916,7 +916,7 @@ PP(pp_untie) mXPUSHi(SvREFCNT(obj) - 1); PUTBACK; ENTER_with_name("call_UNTIE"); - call_sv(MUTABLE_SV(cv), G_VOID); + call_sv(MUTABLE_SV(cv), G_VOID|G_FAKINGMETH); LEAVE_with_name("call_UNTIE"); SPAGAIN; } diff --git a/sv.c b/sv.c index 0c78725..222abb5 100644 --- a/sv.c +++ b/sv.c @@ -5793,7 +5793,7 @@ Perl_sv_clear(pTHX_ register SV *const sv) PUSHMARK(SP); PUSHs(tmpref); PUTBACK; - call_sv(MUTABLE_SV(destructor), G_DISCARD|G_EVAL|G_KEEPERR|G_VOID); + call_sv(MUTABLE_SV(destructor), G_DISCARD|G_EVAL|G_KEEPERR|G_VOID|G_FAKINGMETH); POPSTACK; @@ -12042,7 +12042,7 @@ do_mark_cloneable_stash(pTHX_ SV *const sv) PUSHMARK(SP); mXPUSHs(newSVhek(hvname)); PUTBACK; - call_sv(MUTABLE_SV(GvCV(cloner)), G_SCALAR); + call_sv(MUTABLE_SV(GvCV(cloner)), G_SCALAR|G_FAKINGMETH); SPAGAIN; status = POPu; PUTBACK; @@ -12792,7 +12792,7 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, PUSHMARK(SP); mXPUSHs(newSVhek(HvNAME_HEK(stash))); PUTBACK; - call_sv(MUTABLE_SV(GvCV(cloner)), G_DISCARD); + call_sv(MUTABLE_SV(GvCV(cloner)), G_DISCARD|G_FAKINGMETH); FREETMPS; LEAVE; } -- 1.7.1.1
From 94c99058dfdff8483a7e8bf8c8fd6089660dfd19 Mon Sep 17 00:00:00 2001 From: Ben Morrow <ben@morrow.me.uk> Date: Sun, 19 Sep 2010 20:02:22 +0100 Subject: [PATCH 3/6] Fix attribute method calls to be method calls. --- ext/attributes/attributes.pm | 4 ++-- 1 files changed, 2 insertions(+), 2 deletions(-) diff --git a/ext/attributes/attributes.pm b/ext/attributes/attributes.pm index c117bef..8d4a2d0 100644 --- a/ext/attributes/attributes.pm +++ b/ext/attributes/attributes.pm @@ -52,7 +52,7 @@ sub import { my @badattrs; if ($pkgmeth) { my @pkgattrs = _modify_attrs_and_deprecate($svtype, $svref, @attrs); - @badattrs = $pkgmeth->($home_stash, $svref, @pkgattrs); + @badattrs = $home_stash->$pkgmeth($svref, @pkgattrs); if (!@badattrs && @pkgattrs) { require warnings; return unless warnings::enabled('reserved'); @@ -90,7 +90,7 @@ sub get ($) { $pkgmeth = UNIVERSAL::can($stash, "FETCH_${svtype}_ATTRIBUTES") if defined $stash && $stash ne ''; return $pkgmeth ? - (_fetch_attrs($svref), $pkgmeth->($stash, $svref)) : + (_fetch_attrs($svref), $stash->$pkgmeth($svref)) : (_fetch_attrs($svref)) ; } -- 1.7.1.1
From a53d4686040d595bcec119ebded6787e868c74df Mon Sep 17 00:00:00 2001 From: Ben Morrow <ben@morrow.me.uk> Date: Mon, 20 Sep 2010 21:28:26 +0100 Subject: [PATCH 4/6] Tests for OPpENTERSUB_METHOD. The tests in ext/B have already been updated, to aboid bisection failures. --- MANIFEST | 1 + ext/XS-APItest/APItest.xs | 12 +++ ext/XS-APItest/t/methodcall.t | 218 +++++++++++++++++++++++++++++++++++++++++ 3 files changed, 231 insertions(+), 0 deletions(-) create mode 100644 ext/XS-APItest/t/methodcall.t diff --git a/MANIFEST b/MANIFEST index 3e9583a..6e3e51f 100644 --- a/MANIFEST +++ b/MANIFEST @@ -3336,6 +3336,7 @@ ext/XS-APItest/t/copyhints.t test hv_copy_hints_hv() API ext/XS-APItest/t/exception.t XS::APItest extension ext/XS-APItest/t/hash.t XS::APItest: tests for hash related APIs ext/XS-APItest/t/Markers.pm Helper for ./blockhooks.t +ext/XS-APItest/t/methodcall.t XS::APItest: test OPpENTERSUB_METHOD ext/XS-APItest/t/my_cxt.t XS::APItest: test MY_CXT interface ext/XS-APItest/t/my_exit.t XS::APItest: test my_exit ext/XS-APItest/t/Null.pm Helper for ./blockhooks.t diff --git a/ext/XS-APItest/APItest.xs b/ext/XS-APItest/APItest.xs index c6cac13..2c66b73 100644 --- a/ext/XS-APItest/APItest.xs +++ b/ext/XS-APItest/APItest.xs @@ -1118,6 +1118,18 @@ my_caller(level) XSRETURN(8); +bool +called_as_method(level) + I32 level + PREINIT: + const PERL_CONTEXT *cx; + CODE: + cx = caller_cx(level, NULL); + RETVAL = cx->blk_u16 & OPpENTERSUB_METHOD; + OUTPUT: + RETVAL + + void DPeek (sv) SV *sv diff --git a/ext/XS-APItest/t/methodcall.t b/ext/XS-APItest/t/methodcall.t new file mode 100644 index 0000000..d433a99 --- /dev/null +++ b/ext/XS-APItest/t/methodcall.t @@ -0,0 +1,218 @@ +#!/usr/bin/perl + +use warnings; +use strict; + +use XS::APItest; +use Test::More; + +my $was_meth; +{ + my $count = 0; + + sub was_meth { + my ($name) = @_; + my $B = Test::More->builder; + if ($count == 1) { + $B->ok($was_meth, $name); + } + else { + $B->ok(0, $name); + $B->diag("set_was_meth called $count times, not 1"); + } + $was_meth = undef; + $count = 0; + } + sub wasnt_meth { + $was_meth = !$was_meth; + was_meth @_; + } + sub set_was_meth { + $was_meth = XS::APItest::called_as_method(1); + $count++; + } +} + +sub as_meth { set_was_meth } + +for my $with (qw/no use/) { + eval <<PERL; +$with strict; + +as_meth(); +wasnt_meth "function call ($with strict)"; + +main->as_meth; +was_meth "class method call ($with strict)"; + +my \$obj = bless [], "main"; +\$obj->as_meth; +was_meth "object method call ($with strict)"; + +my \$meth = \\&as_meth; +\$meth->(); +wasnt_meth "indirect function call ($with strict)"; + +main->\$meth; +was_meth "indirect class method call ($with strict)"; + +\$obj->\$meth; +was_meth "indirect object method call ($with strict)"; +PERL +} + +sub tail { goto &as_meth } + +tail; +wasnt_meth "function tailcall"; + +main->tail; +was_meth "method tailcall"; + +{ + local *AUTOLOAD; + *AUTOLOAD = \&as_meth; + + foobar(); + wasnt_meth "AUTOLOADed function call"; + + main->foobar; + was_meth "AUTOLOADed method call"; +} + +sub TIEHASH { + set_was_meth; + return bless []; +} + +tie my %x, "main"; +was_meth "TIEHASH method call"; + +sub FETCH { set_was_meth; return 1 } +my $dummy = $x{foo}; +was_meth "FETCH (real magic) method call"; + +sub EXISTS { + set_was_meth; + return; +} +$dummy = exists $x{foo}; +was_meth "EXISTS (fake magic) method call"; + +sub UNTIE { set_was_meth } +untie %x; +was_meth "UNTIE method call"; + +use overload q/-/ => "as_meth", q/+/ => \&as_meth; +my $obj = bless []; + +$dummy = 0 + $obj; +wasnt_meth "overloaded function call"; + +TODO: { + local $TODO = "overloaded method calls"; + + $dummy = 0 - $obj; + was_meth "overloaded method call"; +} + +$INC{"Import.pm"} = $0; +sub Import::import { set_was_meth } +eval "use Import;"; +was_meth "import method"; + +$INC{"Version.pm"} = $0; +sub Version::VERSION { set_was_meth } +eval "use Version 1.00;"; +was_meth "VERSION method"; + +sub Destroy::DESTROY { set_was_meth } +{ bless [], "Destroy" } +was_meth "DESTROY method"; + +sub Exception::PROPAGATE { + set_was_meth; + return "Oops!"; +} +eval { + eval { die bless [], "Exception" }; + die; +}; +was_meth "PROPAGATE method call"; + +eval q{ + package Attrib; + sub MODIFY_SCALAR_ATTRIBUTES { + main::set_was_meth; + return; + } + our $x : Foo; +}; +was_meth "our attribute MODIFY method call"; + +{ + package Attrib; + my $y : Foo; +} +was_meth "my attribute MODIFY method call"; + +{ + package Attrib; + my $z : Foo = 1; +} +was_meth "my-with-assign attribute MODIFY method call"; + +eval q{ + package Attrib; + BEGIN { *MODIFY_CODE_ATTRIBUTES = \&MODIFY_SCALAR_ATTRIBUTES }; + BEGIN { *MODIFY_CODE_ATTRIBUTES = \&MODIFY_SCALAR_ATTRIBUTES }; + sub foo : Foo { } +}; +was_meth "sub attribute MODIFY method call"; + +{ + package Attrib; + *FETCH_CODE_ATTRIBUTES = \&MODIFY_CODE_ATTRIBUTES; + *FETCH_CODE_ATTRIBUTES = \&MODIFY_CODE_ATTRIBUTES; + attributes::get \&foo; +} +was_meth "attribute FETCH method call"; + +{ + package Cloner; + sub CLONE { main::set_was_meth } + sub CLONE_SKIP { main::set_was_meth; 0; } +} + +require threads; +$dummy = $threads::threads; # SHUT UP +if ($threads::threads) { + my $thr = threads->new(sub { $was_meth }); + was_meth "CLONE_SKIP method call"; + + my $twm = $thr->join; + ok $twm, "CLONE method call"; +} + +call_sv \&as_meth, G_VOID; +wasnt_meth "call_sv function ref call"; + +{ + no strict; + call_sv "as_meth", G_VOID; + wasnt_meth "call_sv function symref call"; +} + +call_sv *as_meth, G_VOID; +wasnt_meth "call_sv function glob call"; + +call_method "as_meth", G_VOID, "main"; +was_meth "call_method class method call"; + +call_method "as_meth", G_VOID, $obj; +was_meth "call_method object method call"; + +call_sv \&as_meth, G_VOID|G_METHOD, "main"; +was_meth "call_sv method call"; + +done_testing; -- 1.7.1.1
From 0c90401814e97a633418187df84a851340f738fa Mon Sep 17 00:00:00 2001 From: Ben Morrow <ben@morrow.me.uk> Date: Mon, 20 Sep 2010 19:47:23 +0100 Subject: [PATCH 5/6] Tell the debugger about method calls. Whenever $DB::sub gets set, also set $DB::method to indicate whether this was a function or a method call. This includes a 'make regen'. --- embed.fnc | 2 +- embedvar.h | 2 ++ intrpvar.h | 5 +++++ perl.c | 4 ++++ pp_ctl.c | 3 ++- pp_hot.c | 3 ++- proto.h | 2 +- sv.c | 1 + util.c | 5 ++++- 9 files changed, 22 insertions(+), 5 deletions(-) diff --git a/embed.fnc b/embed.fnc index 71e6e1c..7f3479e 100644 --- a/embed.fnc +++ b/embed.fnc @@ -418,7 +418,7 @@ s |OP* |gen_constant_list|NULLOK OP* o p |char* |getenv_len |NN const char *env_elem|NN unsigned long *len #endif : Used in pp_ctl.c and pp_hot.c -pox |void |get_db_sub |NULLOK SV **svp|NN CV *cv +pox |void |get_db_sub |NULLOK SV **svp|NN CV *cv|const U32 flags Ap |void |gp_free |NULLOK GV* gv Ap |GP* |gp_ref |NULLOK GP* gp Ap |GV* |gv_add_by_type |NULLOK GV *gv|svtype type diff --git a/embedvar.h b/embedvar.h index 3a9bccc..074b81f 100644 --- a/embedvar.h +++ b/embedvar.h @@ -45,6 +45,7 @@ #define PL_DBcv (vTHX->IDBcv) #define PL_DBgv (vTHX->IDBgv) #define PL_DBline (vTHX->IDBline) +#define PL_DBmethod (vTHX->IDBmethod) #define PL_DBsignal (vTHX->IDBsignal) #define PL_DBsingle (vTHX->IDBsingle) #define PL_DBsub (vTHX->IDBsub) @@ -375,6 +376,7 @@ #define PL_IDBcv PL_DBcv #define PL_IDBgv PL_DBgv #define PL_IDBline PL_DBline +#define PL_IDBmethod PL_DBmethod #define PL_IDBsignal PL_DBsignal #define PL_IDBsingle PL_DBsingle #define PL_IDBsub PL_DBsub diff --git a/intrpvar.h b/intrpvar.h index 4a7d867..dfe07a2 100644 --- a/intrpvar.h +++ b/intrpvar.h @@ -360,6 +360,10 @@ Trace variable used when Perl is run in debugging mode, with the B<-d> switch. This is the C variable which corresponds to Perl's $DB::trace variable. See C<PL_DBsingle>. +=for apidoc mn|SV *|PL_DBmethod +When Perl is run in debugging mode, with the B<-d> switch, this indicates +whether a given call to C<&DB::sub> was for a function or a method. + =cut */ @@ -367,6 +371,7 @@ PERLVAR(IDBsub, GV *) /* *DB::sub */ PERLVAR(IDBsingle, SV *) /* $DB::single */ PERLVAR(IDBtrace, SV *) /* $DB::trace */ PERLVAR(IDBsignal, SV *) /* $DB::signal */ +PERLVAR(IDBmethod, SV *) /* $DB::method */ PERLVAR(Idbargs, AV *) /* args to call listed by caller function */ /* symbol tables */ diff --git a/perl.c b/perl.c index 6a64de0..5106275 100644 --- a/perl.c +++ b/perl.c @@ -954,6 +954,7 @@ perl_destruct(pTHXx) PL_DBsingle = NULL; PL_DBtrace = NULL; PL_DBsignal = NULL; + PL_DBmethod = NULL; PL_DBcv = NULL; PL_dbargs = NULL; PL_debstash = NULL; @@ -3826,6 +3827,9 @@ Perl_init_debugger(pTHX) PL_DBsignal = GvSV((gv_fetchpvs("DB::signal", GV_ADDMULTI, SVt_PV))); if (!SvIOK(PL_DBsignal)) sv_setiv(PL_DBsignal, 0); + PL_DBmethod = GvSV((gv_fetchpvs("DB::method", GV_ADDMULTI, SVt_PV))); + if (!SvOK(PL_DBmethod)) + sv_setsv(PL_DBmethod, &PL_sv_no); PL_curstash = ostash; } diff --git a/pp_ctl.c b/pp_ctl.c index 0a9dcfe..fbbbf1e 100644 --- a/pp_ctl.c +++ b/pp_ctl.c @@ -2643,7 +2643,8 @@ PP(pp_goto) } } if (PERLDB_SUB) { /* Checking curstash breaks DProf. */ - Perl_get_db_sub(aTHX_ NULL, cv); + Perl_get_db_sub(aTHX_ NULL, cv, + (cx->blk_u16 & OPpENTERSUB_METHOD)); if (PERLDB_GOTO) { CV * const gotocv = get_cvs("DB::goto", 0); if (gotocv) { diff --git a/pp_hot.c b/pp_hot.c index 4f043fb..ba76748 100644 --- a/pp_hot.c +++ b/pp_hot.c @@ -2832,7 +2832,8 @@ try_autoload: gimme = GIMME_V; if ((PL_op->op_private & OPpENTERSUB_DB) && GvCV(PL_DBsub) && !CvNODEBUG(cv)) { - Perl_get_db_sub(aTHX_ &sv, cv); + Perl_get_db_sub(aTHX_ &sv, cv, + (PL_op->op_private & OPpENTERSUB_METHOD)); if (CvISXSUB(cv)) PL_curcopdb = PL_curcop; if (CvLVALUE(cv)) { diff --git a/proto.h b/proto.h index 6b1e25b..5c5ee47 100644 --- a/proto.h +++ b/proto.h @@ -873,7 +873,7 @@ PERL_CALLCONV char* Perl_getenv_len(pTHX_ const char *env_elem, unsigned long *l assert(env_elem); assert(len) #endif -PERL_CALLCONV void Perl_get_db_sub(pTHX_ SV **svp, CV *cv) +PERL_CALLCONV void Perl_get_db_sub(pTHX_ SV **svp, CV *cv, const U32 flags) __attribute__nonnull__(pTHX_2); #define PERL_ARGS_ASSERT_GET_DB_SUB \ assert(cv) diff --git a/sv.c b/sv.c index 222abb5..3560aa2 100644 --- a/sv.c +++ b/sv.c @@ -12392,6 +12392,7 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, PL_DBsingle = sv_dup(proto_perl->IDBsingle, param); PL_DBtrace = sv_dup(proto_perl->IDBtrace, param); PL_DBsignal = sv_dup(proto_perl->IDBsignal, param); + PL_DBmethod = sv_dup(proto_perl->IDBmethod, param); /* symbol tables */ PL_defstash = hv_dup_inc(proto_perl->Idefstash, param); diff --git a/util.c b/util.c index 2ab14d7..b95976e 100644 --- a/util.c +++ b/util.c @@ -6483,7 +6483,7 @@ long _ftol2( double dblSource ) { return _ftol( dblSource ); } #endif void -Perl_get_db_sub(pTHX_ SV **svp, CV *cv) +Perl_get_db_sub(pTHX_ SV **svp, CV *cv, const U32 flags) { dVAR; SV * const dbsv = GvSVn(PL_DBsub); @@ -6497,6 +6497,9 @@ Perl_get_db_sub(pTHX_ SV **svp, CV *cv) PL_tainted = FALSE; save_item(dbsv); + save_item(PL_DBmethod); + sv_setsv(PL_DBmethod, + (flags & OPpENTERSUB_METHOD) ? &PL_sv_yes : &PL_sv_no); if (!PERLDB_SUB_NN) { GV * const gv = CvGV(cv); -- 1.7.1.1
From a1b6a6cd80bd525c06918fec6348a2b44bcd1554 Mon Sep 17 00:00:00 2001 From: Ben Morrow <ben@morrow.me.uk> Date: Mon, 20 Sep 2010 21:29:08 +0100 Subject: [PATCH 6/6] Test $DB::method. --- ext/XS-APItest/t/methodcall.t | 24 ++++++++++++++++++++++++ 1 files changed, 24 insertions(+), 0 deletions(-) diff --git a/ext/XS-APItest/t/methodcall.t b/ext/XS-APItest/t/methodcall.t index d433a99..422efa8 100644 --- a/ext/XS-APItest/t/methodcall.t +++ b/ext/XS-APItest/t/methodcall.t @@ -194,6 +194,30 @@ if ($threads::threads) { ok $twm, "CLONE method call"; } +my $DB_meth; +{ + package DB; + sub sub { + $DB_meth = $DB::method; + no strict "refs"; + &$DB::sub; + } +} + +BEGIN { $^P = 1 } +as_meth; +BEGIN { $^P = 0 } + +wasnt_meth "function call under DB::sub"; +ok !$DB_meth, "...reported as function to &DB::sub"; + +BEGIN { $^P = 1 } +main->as_meth; +BEGIN { $^P = 0 } + +was_meth "method call under DB::sub"; +ok $DB_meth, "...reported as method to &DB::sub"; + call_sv \&as_meth, G_VOID; wasnt_meth "call_sv function ref call"; -- 1.7.1.1
Subject: Re: [perl #77974] [PATCH] Record method calls in the context stack
Date: Tue, 28 Sep 2010 13:18:41 +0100
To: perl5-porters [...] perl.org
From: Zefram <zefram [...] fysh.org>
Download (untitled) / with headers
text/plain 683b
Ben Morrow wrote: Show quoted text
>These patches record whether a given stack frame is for a function or a >method call, by adding a new OPpENTERSUB_PRIVATE bit. I need this for >PRE and POST blocks, which have different behaviour depending on whether >a sub is called as a method or not.
Why do you need behaviour to differ based on this? I'm dubious about breaking the equivalence between $foo->bar and $foo->can("bar")->($foo); plenty of code relies on it. If you really do need to make them inequivalent, then the flag should be available through caller(). And G_FAKINGMETH is improperly derogatory: performing a method call through call_sv() is no more fake than $foo->$methodref. -zefram
Subject: Re: [perl #77974] [PATCH] Record method calls in the context stack
Date: Tue, 28 Sep 2010 16:45:48 +0100
To: zefram [...] fysh.org, perl5-porters [...] perl.org
From: Ben Morrow <ben [...] morrow.me.uk>
Download (untitled) / with headers
text/plain 2.3k
Quoth zefram@fysh.org (Zefram): Show quoted text
> Ben Morrow wrote:
> >These patches record whether a given stack frame is for a function or a > >method call, by adding a new OPpENTERSUB_PRIVATE bit. I need this for > >PRE and POST blocks, which have different behaviour depending on whether > >a sub is called as a method or not.
> > Why do you need behaviour to differ based on this?
'Cause that's what the spec says :). PRE and POST assertions are inherited, for method calls only, so I need to know if this is a method call or not (since Perl 5 doesn't distinguish at compile time). I would have though the existence of Devel::Caller::called_as_method was enough to demonstrate this is useful elsewhere, as well. Show quoted text
> I'm dubious about > breaking the equivalence between $foo->bar and $foo->can("bar")->($foo); > plenty of code relies on it.
This is really the important question: do we want to keep blurring the line between function and method, the way Perl 5 always has, or do we want to sharpen it up a bit? IMHO making it possible to cleanly make the distinction is a good thing, and the problems with code that has been making not-method calls will sort themselves out over time. It's not as though any behaviour changes, except that code relying on Devel::Caller::caller_as_method suddenly starts working better than it did before. Choosing to rely on the distinction is entirely up to those writing code that does that. Putting the flag in the core just means 1. it works properly and 2. we are tacitly accepting this is a valid distinction to make. Show quoted text
> If you really do need to make them inequivalent, then the flag should > be available through caller().
Do you think it's worth it? And where would you put it? Yet another return value? Show quoted text
> And G_FAKINGMETH is improperly derogatory: performing a method call > through call_sv() is no more fake than $foo->$methodref.
Yes, it is. call_sv *without* G_METHOD is $method->($obj, @args) (there's no OP_METHOD(_NAMED)? involved at any point). call_sv *with* G_METHOD is $obj->$method(@args), but won't accept a bare CV (only a cvref). My next step was going to be to remove G_FAKINGMETH again, by allowing pp_method to accept a bare CV, and possibly consider removing OP_METHOD(_NAMED)? altogether, but I wanted to have the discussion about whether this was a good idea at all first. As for 'derogatory', I was emulating G_FAKINGEVAL, which does something rather similar. Ben
Subject: Re: [perl #77974] [PATCH] Record method calls in the context stack
Date: Tue, 28 Sep 2010 17:35:09 +0100
To: perl5-porters [...] perl.org
From: Zefram <zefram [...] fysh.org>
Download (untitled) / with headers
text/plain 2.8k
Ben Morrow wrote: Show quoted text
>'Cause that's what the spec says :). PRE and POST assertions are >inherited, for method calls only,
Is this something being copied from Perl 6? In the Perl 5 world, I'd be a lot happier with the method definition specifying whether it's a method, and PRE/POST behaviour being keyed from the definition rather than the use. We already have ways to intensionally distinguish methods from functions, such as the "method" keywords supplied by the various ::Declare modules. They should probably be applying the core's :method (CVf_METHOD) flag, which is currently little used because it has almost no effect in the core. Show quoted text
>I would have though the existence of Devel::Caller::called_as_method was >enough to demonstrate this is useful elsewhere, as well.
As you described it, called_as_method is an excreable hack that doesn't remotely achieve what the name suggests. I'm not inclined to treat it as any kind of demonstration. It might be illuminating to look at the things that currently try to use it, though. Show quoted text
>This is really the important question: do we want to keep blurring the >line between function and method, the way Perl 5 always has, or do we >want to sharpen it up a bit?
It's much more qualitative than that. Functions and methods aren't just blurred, they're *completely equivalent*. It is a feature of the language that a method call constitutes (a) looking up the appropriate method implementation for the invocant and then (b) calling the implementation function with the invocant as its first argument. The two phases are commonly separated, to varying degrees, and the fact that the second phase is precisely an ordinary function call is both an established protocol and very useful. The question before us is whether to introduce a completely new runtime distinction between two kinds of function call. Effectively, a new flag that all callers need to set correctly. Look how well that worked with the UTF-8 flag. In this case, it's not just XS code that needs to change for the new flag, it also affects pure Perl code that performs the second phase of a method call by the use of function call syntax. Show quoted text
>> If you really do need to make them inequivalent, then the flag should >> be available through caller().
> >Do you think it's worth it? And where would you put it? Yet another >return value?
If this distinction, a new flag attached to every function call at runtime, is to be added to the language, then yes, the ability to read that flag needs to be added to the language's stack introspection facility. I'm not averse to it being yet another item (the twelfth) on the returned list. I'd also be happy with some kind of move towards a hash of named items, but I think it would be better to go that way using a new caller-like interface that *only* returns a hash, rather than changing caller to return a hybrid format. -zefram
CC: perl5-porters [...] perl.org
Subject: Re: [perl #77974] [PATCH] Record method calls in the context stack
Date: Tue, 30 Nov 2010 10:27:46 +0000
To: Ben Morrow <ben [...] morrow.me.uk>
From: Nicholas Clark <nick [...] ccl4.org>
Download (untitled) / with headers
text/plain 1.8k
On Wed, Sep 22, 2010 at 12:20:43PM +0100, Ben Morrow wrote: Show quoted text
> Quoth nick@ccl4.org (Nicholas Clark):
> > On Tue, Sep 21, 2010 at 04:15:37PM -0700, Ben Morrow wrote: > >
> > > These patches record whether a given stack frame is for a function or a > > > method call, by adding a new OPpENTERSUB_PRIVATE bit. I need this for > > > PRE and POST blocks, which have different behaviour depending on whether > > > a sub is called as a method or not.
> > > > Aaargh. Attached patches make it easy (or easier) to do some things, but > > really damn hard to do others. I can't even reliably get a list of > > attachments.
> > Is there anything I could have done differently that would make this > easier? Pushed a branch to github? (My understanding was that it is > easier to apply from a mail with am than to add a remote and pull from > there... I suppose 'both' is always an option.)
Sorry for the delay in replying. No, there wasn't anything that I can see that would be easier (and there still isn't). I didn't intended to write a "You're wrong, and I'm not telling you why" response, although I guess I wasn't clear that I was stuck. Show quoted text
> > > I'm not entirely sure about the parts of this which touch B: it's in > > > ext/, so I presume it's not dual-life, but there seem to be lots of > > > dual-life-ish bits of code in there. I haven't made any attempt to > > > preserve compat with older perls; is this wrong?
> > > > Historically, when I was doing maint releases of 5.8.x, I was trying to keep > > one codebase, rather than forking B in maint-5.8 (and subsequently forking > > 3 ways for blead, maint-5.10 and maint-5.8). IIRC There was also a point > > when I was (mistakenly) assuming it was actually dual-lived, and being > > sufficiently defensive to cope with that.
> > So, given the current maint policy (i.e. there's no chance of this going > into any maint), I don't need to worry about it?
No, not really. Nicholas Clark
Subject: Re: [perl #77974] [PATCH] Record method calls in the context stack
From: Zefram <zefram [...] fysh.org>
Date: Mon, 11 Dec 2017 01:24:05 +0000
To: perl5-porters [...] perl.org
Download (untitled) / with headers
text/plain 120b
No further argument in the last six years for the proposed feature to be added. This ticket should be closed. -zefram


This service is sponsored and maintained by Best Practical Solutions and runs on Perl.org infrastructure.

For issues related to this RT instance (aka "perlbug"), please contact perlbug-admin at perl.org