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_gv_fetchpvn_flags
14 static MGVTBL subname_vtbl;
16 #ifndef PERL_MAGIC_ext
17 # define PERL_MAGIC_ext '~'
21 #define SvMAGIC_set(sv, val) (SvMAGIC(sv) = (val))
25 #define Newxz(ptr, num, type) Newz(0, ptr, num, type)
28 MODULE = Sub::Name PACKAGE = Sub::Name
39 HV *stash = CopSTASH(PL_curcop);
40 const char *s, *end = NULL, *begin = NULL;
43 int utf8flag = SvUTF8(name);
44 const char* nameptr = SvPV(name, namelen);
45 int seen_quote = 0, need_subst = 0;
47 if (!SvROK(sub) && SvGMAGICAL(sub))
50 cv = (CV *) SvRV(sub);
51 else if (SvTYPE(sub) == SVt_PVGV)
54 croak(PL_no_usym, "a subroutine");
55 else if (PL_op->op_private & HINT_STRICT_REFS)
56 croak("Can't use string (\"%.32s\") as %s ref while \"strict refs\" in use",
57 SvPV_nolen(sub), "a subroutine");
58 else if ((gv = gv_fetchsv(sub, FALSE, SVt_PVCV)))
61 croak("Undefined subroutine %s", SvPV_nolen(sub));
62 if (SvTYPE(cv) != SVt_PVCV && SvTYPE(cv) != SVt_PVFM)
63 croak("Not a subroutine reference");
65 for (s = nameptr; s <= nameptr + namelen; s++) {
66 if (*s == ':' && s[-1] == ':') {
72 else if (*s && s[-1] == '\'') {
83 STRLEN length = end - nameptr + seen_quote - (*end == '\'' ? 1 : 0);
88 for (i = 0, j = 0; j < end - nameptr; ++i, ++j) {
89 if (nameptr[j] == '\'') {
97 stash = gv_stashpvn(left, length, GV_ADD | utf8flag);
101 stash = gv_stashpvn(nameptr, end - nameptr, GV_ADD | utf8flag);
103 namelen -= begin - nameptr;
106 #ifdef PERL_VERSION < 10
107 /* under debugger, provide information about sub location */
108 if (PL_DBsub && CvGV(cv)) {
109 HV *hv = GvHV(PL_DBsub);
112 char* new_pkg = HvNAME(stash);
114 char* old_name = GvNAME( CvGV(cv) );
115 char* old_pkg = HvNAME( GvSTASH(CvGV(cv)) );
117 int old_len = strlen(old_name) + strlen(old_pkg);
118 int new_len = namelen + strlen(new_pkg);
121 Newxz(full_name, (old_len > new_len ? old_len : new_len) + 3, char);
123 strcat(full_name, old_pkg);
124 strcat(full_name, "::");
125 strcat(full_name, old_name);
127 old_data = hv_fetch(hv, full_name, strlen(full_name), 0);
130 strcpy(full_name, new_pkg);
131 strcat(full_name, "::");
132 strcat(full_name, nameptr);
134 SvREFCNT_inc(*old_data);
135 if (!hv_store(hv, full_name, strlen(full_name), *old_data, 0))
136 SvREFCNT_dec(*old_data);
142 gv = (GV *) newSV(0);
143 gv_init_pvn(gv, stash, nameptr, s - nameptr, GV_ADDMULTI | utf8flag);
146 while (mg && mg->mg_virtual != &subname_vtbl)
147 mg = mg->mg_moremagic;
150 mg->mg_moremagic = SvMAGIC(cv);
151 mg->mg_type = PERL_MAGIC_ext;
152 mg->mg_virtual = &subname_vtbl;
155 if (mg->mg_flags & MGf_REFCOUNTED)
156 SvREFCNT_dec(mg->mg_obj);
157 mg->mg_flags |= MGf_REFCOUNTED;
158 mg->mg_obj = (SV *) gv;