1/* Copyright (C) 2004, 2008  Matthijs van Duin.  All rights reserved.
2 * This program is free software; you can redistribute it and/or modify
3 * it under the same terms as Perl itself.
4 */
5
6#include "EXTERN.h"
7#include "perl.h"
8#include "XSUB.h"
9
10static MGVTBL subname_vtbl;
11
12#ifndef PERL_MAGIC_ext
13# define PERL_MAGIC_ext '~'
14#endif
15
16#ifndef SvMAGIC_set
17#define SvMAGIC_set(sv, val) (SvMAGIC(sv) = (val))
18#endif
19
20
21MODULE = Sub::Name  PACKAGE = Sub::Name
22
23PROTOTYPES: DISABLE
24
25void
26subname(name, sub)
27	char *name
28	SV *sub
29    PREINIT:
30	CV *cv = NULL;
31	GV *gv;
32	HV *stash = CopSTASH(PL_curcop);
33	char *s, *end = NULL, saved;
34    PPCODE:
35	if (!SvROK(sub) && SvGMAGICAL(sub))
36		mg_get(sub);
37	if (SvROK(sub))
38		cv = (CV *) SvRV(sub);
39	else if (SvTYPE(sub) == SVt_PVGV)
40		cv = GvCVu(sub);
41	else if (!SvOK(sub))
42		croak(PL_no_usym, "a subroutine");
43	else if (PL_op->op_private & HINT_STRICT_REFS)
44		croak(PL_no_symref, SvPV_nolen(sub), "a subroutine");
45	else if ((gv = gv_fetchpv(SvPV_nolen(sub), FALSE, SVt_PVCV)))
46		cv = GvCVu(gv);
47	if (!cv)
48		croak("Undefined subroutine %s", SvPV_nolen(sub));
49	if (SvTYPE(cv) != SVt_PVCV && SvTYPE(cv) != SVt_PVFM)
50		croak("Not a subroutine reference");
51	for (s = name; *s++; ) {
52		if (*s == ':' && s[-1] == ':')
53			end = ++s;
54		else if (*s && s[-1] == '\'')
55			end = s;
56	}
57	s--;
58	if (end) {
59		saved = *end;
60		*end = 0;
61		stash = GvHV(gv_fetchpv(name, TRUE, SVt_PVHV));
62		*end = saved;
63		name = end;
64	}
65	gv = (GV *) newSV(0);
66	gv_init(gv, stash, name, s - name, TRUE);
67#ifndef USE_5005THREADS
68	if (CvPADLIST(cv)) {
69		/* cheap way to refcount the gv */
70		av_store((AV *) AvARRAY(CvPADLIST(cv))[0], 0, (SV *) gv);
71	} else
72#endif
73	{
74		/* expensive way to refcount the gv */
75		MAGIC *mg = SvMAGIC(cv);
76		while (mg && mg->mg_virtual != &subname_vtbl)
77			mg = mg->mg_moremagic;
78		if (!mg) {
79			Newz(702, mg, 1, MAGIC);
80			mg->mg_moremagic = SvMAGIC(cv);
81			mg->mg_type = PERL_MAGIC_ext;
82			mg->mg_virtual = &subname_vtbl;
83			SvMAGIC_set(cv, mg);
84		}
85		if (mg->mg_flags & MGf_REFCOUNTED)
86			SvREFCNT_dec(mg->mg_obj);
87		mg->mg_flags |= MGf_REFCOUNTED;
88		mg->mg_obj = (SV *) gv;
89	}
90	CvGV(cv) = gv;
91	PUSHs(sub);
92