1 /* Copyright (C) 2004, 2008 Matthijs van Duin. All rights reserved.
2 * Copyright (C) 2014, cPanel Inc. All rights reserved.
3 * This program is free software; you can redistribute it and/or modify
4 * it under the same terms as Perl itself.
10 #define NEED_sv_2pv_flags
11 #define NEED_newSVpvn_flags
12 #define NEED_gv_fetchpvn_flags
13 #define NEED_sv_catpvn_flags
16 static MGVTBL subname_vtbl;
18 #ifndef PERL_MAGIC_ext
19 # define PERL_MAGIC_ext '~'
23 #define SvMAGIC_set(sv, val) (SvMAGIC(sv) = (val))
27 #define Newxz(ptr, num, type) Newz(0, ptr, num, type)
31 #define HvNAMELEN_get(stash) strlen(HvNAME(stash))
35 #define HvNAMEUTF8(stash) 0
40 #define GvNAMEUTF8(gv) HEK_UTF8(GvNAME_HEK(gv))
42 #define GvNAMEUTF8(gv) 0
54 #ifndef sv_catpvn_flags
55 #define sv_catpvn_flags(b,n,l,f) sv_catpvn(b,n,l)
58 MODULE = Sub::Name PACKAGE = Sub::Name
69 HV *stash = CopSTASH(PL_curcop);
70 const char *s, *end = NULL, *begin = NULL;
73 const char* nameptr = SvPV(name, namelen);
74 int utf8flag = SvUTF8(name);
75 int seen_quote = 0, need_subst = 0;
77 if (!SvROK(sub) && SvGMAGICAL(sub))
80 cv = (CV *) SvRV(sub);
81 else if (SvTYPE(sub) == SVt_PVGV)
84 croak(PL_no_usym, "a subroutine");
85 else if (PL_op->op_private & HINT_STRICT_REFS)
86 croak("Can't use string (\"%.32s\") as %s ref while \"strict refs\" in use",
87 SvPV_nolen(sub), "a subroutine");
88 else if ((gv = gv_fetchsv(sub, FALSE, SVt_PVCV)))
91 croak("Undefined subroutine %s", SvPV_nolen(sub));
92 if (SvTYPE(cv) != SVt_PVCV && SvTYPE(cv) != SVt_PVFM)
93 croak("Not a subroutine reference");
95 for (s = nameptr; s <= nameptr + namelen; s++) {
96 if (s > nameptr && *s == ':' && s[-1] == ':') {
102 else if (s > nameptr && *s != '\0' && s[-1] == '\'') {
113 STRLEN length = end - nameptr + seen_quote - (*end == '\'' ? 1 : 0);
118 for (i = 0, j = 0; j < end - nameptr; ++i, ++j) {
119 if (nameptr[j] == '\'') {
124 left[i] = nameptr[j];
127 stash = gv_stashpvn(left, length, GV_ADD | utf8flag);
131 stash = gv_stashpvn(nameptr, end - nameptr, GV_ADD | utf8flag);
133 namelen -= begin - nameptr;
136 /* under debugger, provide information about sub location */
137 if (PL_DBsub && CvGV(cv)) {
138 HV* DBsub = GvHV(PL_DBsub);
141 GV* oldgv = CvGV(cv);
142 HV* oldhv = GvSTASH(oldgv);
143 SV* old_full_name = newSVpvn_flags(HvNAME(oldhv), HvNAMELEN_get(oldhv), HvNAMEUTF8(oldhv) ? SVf_UTF8 : 0);
144 sv_catpvn(old_full_name, "::", 2);
145 sv_catpvn_flags(old_full_name, GvNAME(oldgv), GvNAMELEN(oldgv), GvNAMEUTF8(oldgv) ? SV_CATUTF8 : SV_CATBYTES);
147 old_data = hv_fetch_ent(DBsub, old_full_name, 0, 0);
149 SvREFCNT_dec(old_full_name);
151 if (old_data && HeVAL(old_data)) {
152 SV* new_full_name = newSVpvn_flags(HvNAME(stash), HvNAMELEN_get(stash), HvNAMEUTF8(stash) ? SVf_UTF8 : 0);
153 sv_catpvn(new_full_name, "::", 2);
154 sv_catpvn_flags(new_full_name, nameptr, s - nameptr, utf8flag ? SV_CATUTF8 : SV_CATBYTES);
155 SvREFCNT_inc(HeVAL(old_data));
156 if (hv_store_ent(DBsub, new_full_name, HeVAL(old_data), 0) != NULL)
157 SvREFCNT_inc(HeVAL(old_data));
158 SvREFCNT_dec(new_full_name);
162 gv = (GV *) newSV(0);
163 gv_init_pvn(gv, stash, nameptr, s - nameptr, GV_ADDMULTI | utf8flag);
166 while (mg && mg->mg_virtual != &subname_vtbl)
167 mg = mg->mg_moremagic;
170 mg->mg_moremagic = SvMAGIC(cv);
171 mg->mg_type = PERL_MAGIC_ext;
172 mg->mg_virtual = &subname_vtbl;
175 if (mg->mg_flags & MGf_REFCOUNTED)
176 SvREFCNT_dec(mg->mg_obj);
177 mg->mg_flags |= MGf_REFCOUNTED;
178 mg->mg_obj = (SV *) gv;