Skip to content
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

Closed
p5pRT opened this issue Sep 21, 2010 · 26 comments
Closed

[PATCH] Record method calls in the context stack #10652

p5pRT opened this issue Sep 21, 2010 · 26 comments

Comments

@p5pRT
Copy link

@p5pRT p5pRT commented Sep 21, 2010

Migrated from rt.perl.org#77974 (status was 'rejected')

Searchable as RT77974$

@p5pRT
Copy link
Author

@p5pRT p5pRT commented Sep 21, 2010

From ben@morrow.me.uk

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

@p5pRT
Copy link
Author

@p5pRT p5pRT commented Sep 21, 2010

From ben@morrow.me.uk

0001-Record-method-calls-in-the-context-stack.patch
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

@p5pRT
Copy link
Author

@p5pRT p5pRT commented Sep 21, 2010

From ben@morrow.me.uk

0002-Tests-for-OPpENTERSUB_METHOD.patch
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

@p5pRT
Copy link
Author

@p5pRT p5pRT commented Sep 21, 2010

From ben@morrow.me.uk

0003-Make-all-the-magic-method-calls-method-calls.patch
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

@p5pRT
Copy link
Author

@p5pRT p5pRT commented Sep 21, 2010

From ben@morrow.me.uk

0004-Fix-attribute-method-calls-to-be-method-calls.patch
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

@p5pRT
Copy link
Author

@p5pRT p5pRT commented Sep 21, 2010

From ben@morrow.me.uk

0005-Tell-the-debugger-about-method-calls.patch
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

@p5pRT
Copy link
Author

@p5pRT p5pRT commented Sep 21, 2010

From ben@morrow.me.uk

0006-make-regen.patch
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

@p5pRT
Copy link
Author

@p5pRT p5pRT commented Sep 21, 2010

From ben@morrow.me.uk

0007-Test-DB-method.patch
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

@p5pRT
Copy link
Author

@p5pRT p5pRT commented Sep 21, 2010

From ben@morrow.me.uk

0008-Update-MANIFEST.patch
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

@p5pRT
Copy link
Author

@p5pRT p5pRT commented Sep 21, 2010

From ben@morrow.me.uk

0009-Fixup-the-tests-in-ext-B-for-OPpENTERSUB_METHOD.patch
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

@p5pRT
Copy link
Author

@p5pRT p5pRT commented Sep 22, 2010

From @nwc10

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.

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.

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

@p5pRT
Copy link
Author

@p5pRT p5pRT commented Sep 22, 2010

The RT System itself - Status changed from 'new' to 'open'

@p5pRT
Copy link
Author

@p5pRT p5pRT commented Sep 22, 2010

From ben@morrow.me.uk

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.)

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.

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

@p5pRT
Copy link
Author

@p5pRT p5pRT commented Sep 23, 2010

From ben@morrow.me.uk

At 12PM +0100 on 22/09/10 I wrote​:

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

@p5pRT
Copy link
Author

@p5pRT p5pRT commented Sep 23, 2010

From ben@morrow.me.uk

0001-Record-method-calls-in-the-context-stack.patch
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

@p5pRT
Copy link
Author

@p5pRT p5pRT commented Sep 23, 2010

From ben@morrow.me.uk

0002-Make-all-the-magic-method-calls-method-calls.patch
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

@p5pRT
Copy link
Author

@p5pRT p5pRT commented Sep 23, 2010

From ben@morrow.me.uk

0003-Fix-attribute-method-calls-to-be-method-calls.patch
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

@p5pRT
Copy link
Author

@p5pRT p5pRT commented Sep 23, 2010

From ben@morrow.me.uk

0004-Tests-for-OPpENTERSUB_METHOD.patch
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

@p5pRT
Copy link
Author

@p5pRT p5pRT commented Sep 23, 2010

From ben@morrow.me.uk

0005-Tell-the-debugger-about-method-calls.patch
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

@p5pRT
Copy link
Author

@p5pRT p5pRT commented Sep 23, 2010

From ben@morrow.me.uk

0006-Test-DB-method.patch
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

@p5pRT
Copy link
Author

@p5pRT p5pRT commented Sep 28, 2010

From zefram@fysh.org

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? 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

@p5pRT
Copy link
Author

@p5pRT p5pRT commented Sep 28, 2010

From ben@morrow.me.uk

Quoth zefram@​fysh.org (Zefram)​:

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.

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.

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?

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

@p5pRT
Copy link
Author

@p5pRT p5pRT commented Sep 28, 2010

From zefram@fysh.org

Ben Morrow wrote​:

'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.

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.

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.

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

@p5pRT
Copy link
Author

@p5pRT p5pRT commented Nov 30, 2010

From @nwc10

On Wed, Sep 22, 2010 at 12​:20​:43PM +0100, Ben Morrow wrote​:

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.

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

@p5pRT
Copy link
Author

@p5pRT p5pRT commented Dec 11, 2017

From zefram@fysh.org

No further argument in the last six years for the proposed feature to
be added. This ticket should be closed.

-zefram

@p5pRT
Copy link
Author

@p5pRT p5pRT commented Dec 11, 2017

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

Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment
Projects
None yet
Development

No branches or pull requests

1 participant