New issue
Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.
By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.
Already on GitHub? Sign in to your account
[PATCH] Record method calls in the context stack #10652
Comments
From ben@morrow.me.ukThese patches record whether a given stack frame is for a function or a I looked at Devel::Caller::called_as_method, but unfortunately it gets ~% perl -MDevel::Caller::called_as_method While this particular bug could possibly be fixed, the general approach I haven't attempted to export the flag to Perl, since I don't see I'm not entirely sure about the parts of this which touch B: it's in Ben |
From ben@morrow.me.uk0001-Record-method-calls-in-the-context-stack.patchFrom 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 ben@morrow.me.uk0002-Tests-for-OPpENTERSUB_METHOD.patchFrom 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 ben@morrow.me.uk0003-Make-all-the-magic-method-calls-method-calls.patchFrom 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 ben@morrow.me.uk0004-Fix-attribute-method-calls-to-be-method-calls.patchFrom 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 ben@morrow.me.uk0005-Tell-the-debugger-about-method-calls.patchFrom 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 ben@morrow.me.uk0006-make-regen.patchFrom 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 ben@morrow.me.uk0007-Test-DB-method.patchFrom 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 ben@morrow.me.uk0008-Update-MANIFEST.patchFrom 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 ben@morrow.me.uk0009-Fixup-the-tests-in-ext-B-for-OPpENTERSUB_METHOD.patchFrom 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
|
From @nwc10On Tue, Sep 21, 2010 at 04:15:37PM -0700, Ben Morrow wrote:
Aaargh. Attached patches make it easy (or easier) to do some things, but Anyway, what I wanted to say was that I'd not looked that the detail of I think that the "add the new file to the MANIFEST" patch should be part of I think that the "some of these fail" comment in a test shouldn't be there,
Historically, when I was doing maint releases of 5.8.x, I was trying to keep Nicholas Clark |
The RT System itself - Status changed from 'new' to 'open' |
From ben@morrow.me.ukQuoth nick@ccl4.org (Nicholas Clark):
Is there anything I could have done differently that would make this
OK, makes sense. I'll resubmit when I've had a chance to rebase into the
So, given the current maint policy (i.e. there's no chance of this going Ben |
From ben@morrow.me.ukAt 12PM +0100 on 22/09/10 I wrote:
Attached. Ben |
From ben@morrow.me.uk0001-Record-method-calls-in-the-context-stack.patchFrom 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 ben@morrow.me.uk0002-Make-all-the-magic-method-calls-method-calls.patchFrom 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 ben@morrow.me.uk0003-Fix-attribute-method-calls-to-be-method-calls.patchFrom 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 ben@morrow.me.uk0004-Tests-for-OPpENTERSUB_METHOD.patchFrom 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 ben@morrow.me.uk0005-Tell-the-debugger-about-method-calls.patchFrom 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 ben@morrow.me.uk0006-Test-DB-method.patchFrom 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
|
From zefram@fysh.orgBen Morrow wrote:
Why do you need behaviour to differ based on this? I'm dubious about -zefram |
From ben@morrow.me.ukQuoth zefram@fysh.org (Zefram):
'Cause that's what the spec says :). PRE and POST assertions are I would have though the existence of Devel::Caller::called_as_method was
This is really the important question: do we want to keep blurring the It's not as though any behaviour changes, except that code relying on
Do you think it's worth it? And where would you put it? Yet another
Yes, it is. call_sv *without* G_METHOD is $method->($obj, @args) As for 'derogatory', I was emulating G_FAKINGEVAL, which does something Ben |
From zefram@fysh.orgBen Morrow wrote:
Is this something being copied from Perl 6? In the Perl 5 world, I'd be a lot happier with the method definition
As you described it, called_as_method is an excreable hack that doesn't
It's much more qualitative than that. Functions and methods aren't just The question before us is whether to introduce a completely new
If this distinction, a new flag attached to every function call at -zefram |
From @nwc10On Wed, Sep 22, 2010 at 12:20:43PM +0100, Ben Morrow wrote:
Sorry for the delay in replying.
No, not really. Nicholas Clark |
From zefram@fysh.orgNo further argument in the last six years for the proposed feature to -zefram |
@cpansprout - Status changed from 'open' to 'rejected' |
Migrated from rt.perl.org#77974 (status was 'rejected')
Searchable as RT77974$
The text was updated successfully, but these errors were encountered: