Added function amagic_find(sv, method, flags)

Returns the CV pointer to the overloaded method,
which will be needed by join to detect concat magic.

Co-authored-by: Philippe Bruhat (BooK) <book@cpan.org>

4 files changed, 47 insertions, 0 deletions

diff --git a/embed.fnc b/embed.fnc
index 5ad6b80675..745153dc49 100644
--- a/embed.fnc
+++ b/embed.fnc
@@ -635,6 +635,7 @@ XEop	|bool	|try_amagic_bin	|int method|int flags
 XEop	|bool	|try_amagic_un	|int method|int flags
 Apd	|SV*	|amagic_call	|NN SV* left|NN SV* right|int method|int dir
 Apd	|SV *	|amagic_deref_call|NN SV *ref|int method
+Apd	|CV *	|amagic_find	|NN SV *sv|int method|int flags
 p	|bool	|amagic_is_enabled|int method
 Apd	|int	|Gv_AMupdate	|NN HV* stash|bool destructing
 CpdR	|CV*	|gv_handler	|NULLOK HV* stash|I32 id
diff --git a/embed.h b/embed.h
index 694aaf5578..0c35f76a77 100644
--- a/embed.h
+++ b/embed.h
@@ -59,6 +59,7 @@
 #define _utf8n_to_uvchr_msgs_helper	Perl__utf8n_to_uvchr_msgs_helper
 #define amagic_call(a,b,c,d)	Perl_amagic_call(aTHX_ a,b,c,d)
 #define amagic_deref_call(a,b)	Perl_amagic_deref_call(aTHX_ a,b)
+#define amagic_find(a,b,c)	Perl_amagic_find(aTHX_ a,b,c)
 #define apply_attrs_string(a,b,c,d)	Perl_apply_attrs_string(aTHX_ a,b,c,d)
 #define apply_builtin_cv_attributes(a,b)	Perl_apply_builtin_cv_attributes(aTHX_ a,b)
 #define atfork_lock		Perl_atfork_lock
diff --git a/gv.c b/gv.c
index 0982fee380..030ecd9123 100644
--- a/gv.c
+++ b/gv.c
@@ -3377,6 +3377,48 @@ Perl_try_amagic_un(pTHX_ int method, int flags) {
 }
 
 
+/*
+=for apidoc amagic_find
+
+Check C<sv> for the overloaded (active magic) operation C<method>, and
+return the C<CV *> or C<NULL>.
+
+C<method> is one of the values found in F<overload.h>.
+
+C<flags> are available for future use.
+
+=cut
+*/
+CV *
+Perl_amagic_find(pTHX_ SV *sv, int method, int flags)
+{
+    PERL_ARGS_ASSERT_AMAGIC_FIND;
+    PERL_UNUSED_VAR(flags);
+
+    assert(method >= 0 && method < NofAMmeth);
+
+    if (!SvAMAGIC(sv))
+        return NULL;
+
+    HV *stash = SvSTASH(SvRV(sv));
+    if (!Gv_AMG(stash))
+        return NULL;
+
+    MAGIC *mg = mg_find((const SV *)stash, PERL_MAGIC_overload_table);
+    if (!mg)
+        return NULL;
+
+    CV **cvp = NULL;
+    if (AMT_AMAGIC((AMT *)mg->mg_ptr))
+        cvp = ((AMT *)mg->mg_ptr)->table;
+    if (!cvp)
+        return NULL;
+
+    CV *cv = cvp[method];
+    return cv;
+}
+
+
 /* Implement tryAMAGICbin_MG macro.
    Do get magic, then see if the two stack args are overloaded and if so
    call it.
diff --git a/proto.h b/proto.h
index ac517eb5d3..91a7759abf 100644
--- a/proto.h
+++ b/proto.h
@@ -252,6 +252,9 @@ PERL_CALLCONV SV*	Perl_amagic_call(pTHX_ SV* left, SV* right, int method, int di
 PERL_CALLCONV SV *	Perl_amagic_deref_call(pTHX_ SV *ref, int method);
 #define PERL_ARGS_ASSERT_AMAGIC_DEREF_CALL	\
 	assert(ref)
+PERL_CALLCONV CV *	Perl_amagic_find(pTHX_ SV *sv, int method, int flags);
+#define PERL_ARGS_ASSERT_AMAGIC_FIND	\
+	assert(sv)
 PERL_CALLCONV bool	Perl_amagic_is_enabled(pTHX_ int method)
 			__attribute__visibility__("hidden");
 #define PERL_ARGS_ASSERT_AMAGIC_IS_ENABLED