Commit | Line | Data |
979516cc |
1 | /* Copyright (C) 2004, 2008 Matthijs van Duin. All rights reserved. |
24f50a79 |
2 | * Copyright (C) 2014, cPanel Inc. All rights reserved. |
65b620dd |
3 | * This program is free software; you can redistribute it and/or modify |
16c23894 |
4 | * it under the same terms as Perl itself. |
5 | */ |
6 | |
7 | #include "EXTERN.h" |
8 | #include "perl.h" |
9 | #include "XSUB.h" |
eb7c69cd |
10 | #define NEED_sv_2pv_flags |
456cbdf2 |
11 | #define NEED_newSVpvn_flags |
eb7c69cd |
12 | #define NEED_gv_fetchpvn_flags |
356a8ce3 |
13 | #define NEED_sv_catpvn_flags |
8b9e2362 |
14 | #define NEED_croak_xs_usage /* running `perl ppport.h Name.xs` suggests removing this, but don't! see RT#125158 */ |
3b02e094 |
15 | #include "ppport.h" |
16c23894 |
16 | |
bbd01306 |
17 | static MGVTBL subname_vtbl; |
16c23894 |
18 | |
979516cc |
19 | #ifndef PERL_MAGIC_ext |
20 | # define PERL_MAGIC_ext '~' |
21 | #endif |
22 | |
23 | #ifndef SvMAGIC_set |
24 | #define SvMAGIC_set(sv, val) (SvMAGIC(sv) = (val)) |
25 | #endif |
26 | |
bcbff2c1 |
27 | #ifndef Newxz |
28 | #define Newxz(ptr, num, type) Newz(0, ptr, num, type) |
29 | #endif |
979516cc |
30 | |
456cbdf2 |
31 | #ifndef HvNAMELEN_get |
32 | #define HvNAMELEN_get(stash) strlen(HvNAME(stash)) |
33 | #endif |
34 | |
35 | #ifndef HvNAMEUTF8 |
36 | #define HvNAMEUTF8(stash) 0 |
37 | #endif |
38 | |
39 | #ifndef GvNAMEUTF8 |
40 | #ifdef GvNAME_HEK |
41 | #define GvNAMEUTF8(gv) HEK_UTF8(GvNAME_HEK(gv)) |
42 | #else |
43 | #define GvNAMEUTF8(gv) 0 |
44 | #endif |
45 | #endif |
46 | |
47 | #ifndef SV_CATUTF8 |
48 | #define SV_CATUTF8 0 |
49 | #endif |
50 | |
51 | #ifndef SV_CATBYTES |
52 | #define SV_CATBYTES 0 |
53 | #endif |
54 | |
356a8ce3 |
55 | #ifndef sv_catpvn_flags |
56 | #define sv_catpvn_flags(b,n,l,f) sv_catpvn(b,n,l) |
57 | #endif |
58 | |
16c23894 |
59 | MODULE = Sub::Name PACKAGE = Sub::Name |
60 | |
61 | PROTOTYPES: DISABLE |
62 | |
63 | void |
64 | subname(name, sub) |
eb7c69cd |
65 | SV *name |
16c23894 |
66 | SV *sub |
67 | PREINIT: |
68 | CV *cv = NULL; |
69 | GV *gv; |
70 | HV *stash = CopSTASH(PL_curcop); |
12e89eea |
71 | const char *s, *end = NULL, *begin = NULL; |
fa213968 |
72 | MAGIC *mg; |
eb7c69cd |
73 | STRLEN namelen; |
eb7c69cd |
74 | const char* nameptr = SvPV(name, namelen); |
d691461d |
75 | int utf8flag = SvUTF8(name); |
2fa23705 |
76 | int quotes_seen = 0; |
77 | bool need_subst = FALSE; |
16c23894 |
78 | PPCODE: |
79 | if (!SvROK(sub) && SvGMAGICAL(sub)) |
80 | mg_get(sub); |
81 | if (SvROK(sub)) |
82 | cv = (CV *) SvRV(sub); |
83 | else if (SvTYPE(sub) == SVt_PVGV) |
84 | cv = GvCVu(sub); |
85 | else if (!SvOK(sub)) |
86 | croak(PL_no_usym, "a subroutine"); |
87 | else if (PL_op->op_private & HINT_STRICT_REFS) |
65b620dd |
88 | croak("Can't use string (\"%.32s\") as %s ref while \"strict refs\" in use", |
89 | SvPV_nolen(sub), "a subroutine"); |
eb7c69cd |
90 | else if ((gv = gv_fetchsv(sub, FALSE, SVt_PVCV))) |
16c23894 |
91 | cv = GvCVu(gv); |
92 | if (!cv) |
93 | croak("Undefined subroutine %s", SvPV_nolen(sub)); |
94 | if (SvTYPE(cv) != SVt_PVCV && SvTYPE(cv) != SVt_PVFM) |
95 | croak("Not a subroutine reference"); |
eb7c69cd |
96 | |
97 | for (s = nameptr; s <= nameptr + namelen; s++) { |
f90d35be |
98 | if (s > nameptr && *s == ':' && s[-1] == ':') { |
12e89eea |
99 | end = s - 1; |
100 | begin = ++s; |
2fa23705 |
101 | if (quotes_seen) |
102 | need_subst = TRUE; |
12e89eea |
103 | } |
f90d35be |
104 | else if (s > nameptr && *s != '\0' && s[-1] == '\'') { |
12e89eea |
105 | end = s - 1; |
106 | begin = s; |
2fa23705 |
107 | if (quotes_seen++) |
108 | need_subst = TRUE; |
12e89eea |
109 | } |
16c23894 |
110 | } |
111 | s--; |
eb7c69cd |
112 | if (end) { |
12e89eea |
113 | SV* tmp; |
9f60da16 |
114 | if (need_subst) { |
2fa23705 |
115 | STRLEN length = end - nameptr + quotes_seen - (*end == '\'' ? 1 : 0); |
12e89eea |
116 | char* left; |
117 | int i, j; |
46141c8e |
118 | tmp = sv_2mortal(newSV(length)); |
12e89eea |
119 | left = SvPVX(tmp); |
9f60da16 |
120 | for (i = 0, j = 0; j < end - nameptr; ++i, ++j) { |
12e89eea |
121 | if (nameptr[j] == '\'') { |
122 | left[i] = ':'; |
123 | left[++i] = ':'; |
124 | } |
125 | else { |
126 | left[i] = nameptr[j]; |
127 | } |
128 | } |
9f60da16 |
129 | stash = gv_stashpvn(left, length, GV_ADD | utf8flag); |
12e89eea |
130 | } |
131 | else |
132 | stash = gv_stashpvn(nameptr, end - nameptr, GV_ADD | utf8flag); |
133 | nameptr = begin; |
134 | namelen -= begin - nameptr; |
eb7c69cd |
135 | } |
3967e628 |
136 | |
137 | /* under debugger, provide information about sub location */ |
138 | if (PL_DBsub && CvGV(cv)) { |
456cbdf2 |
139 | HV* DBsub = GvHV(PL_DBsub); |
140 | HE* old_data; |
141 | |
142 | GV* oldgv = CvGV(cv); |
143 | HV* oldhv = GvSTASH(oldgv); |
46141c8e |
144 | SV* old_full_name = sv_2mortal(newSVpvn_flags(HvNAME(oldhv), HvNAMELEN_get(oldhv), HvNAMEUTF8(oldhv) ? SVf_UTF8 : 0)); |
456cbdf2 |
145 | sv_catpvn(old_full_name, "::", 2); |
146 | sv_catpvn_flags(old_full_name, GvNAME(oldgv), GvNAMELEN(oldgv), GvNAMEUTF8(oldgv) ? SV_CATUTF8 : SV_CATBYTES); |
147 | |
148 | old_data = hv_fetch_ent(DBsub, old_full_name, 0, 0); |
149 | |
456cbdf2 |
150 | if (old_data && HeVAL(old_data)) { |
46141c8e |
151 | SV* new_full_name = sv_2mortal(newSVpvn_flags(HvNAME(stash), HvNAMELEN_get(stash), HvNAMEUTF8(stash) ? SVf_UTF8 : 0)); |
456cbdf2 |
152 | sv_catpvn(new_full_name, "::", 2); |
153 | sv_catpvn_flags(new_full_name, nameptr, s - nameptr, utf8flag ? SV_CATUTF8 : SV_CATBYTES); |
154 | SvREFCNT_inc(HeVAL(old_data)); |
155 | if (hv_store_ent(DBsub, new_full_name, HeVAL(old_data), 0) != NULL) |
156 | SvREFCNT_inc(HeVAL(old_data)); |
3967e628 |
157 | } |
3967e628 |
158 | } |
159 | |
16c23894 |
160 | gv = (GV *) newSV(0); |
eb7c69cd |
161 | gv_init_pvn(gv, stash, nameptr, s - nameptr, GV_ADDMULTI | utf8flag); |
fa213968 |
162 | |
163 | mg = SvMAGIC(cv); |
164 | while (mg && mg->mg_virtual != &subname_vtbl) |
165 | mg = mg->mg_moremagic; |
166 | if (!mg) { |
bcbff2c1 |
167 | Newxz(mg, 1, MAGIC); |
fa213968 |
168 | mg->mg_moremagic = SvMAGIC(cv); |
169 | mg->mg_type = PERL_MAGIC_ext; |
170 | mg->mg_virtual = &subname_vtbl; |
171 | SvMAGIC_set(cv, mg); |
bbd01306 |
172 | } |
fa213968 |
173 | if (mg->mg_flags & MGf_REFCOUNTED) |
174 | SvREFCNT_dec(mg->mg_obj); |
175 | mg->mg_flags |= MGf_REFCOUNTED; |
176 | mg->mg_obj = (SV *) gv; |
5804808d |
177 | SvRMAGICAL_on(cv); |
178 | CvANON_off(cv); |
08e37985 |
179 | #ifndef CvGV_set |
16c23894 |
180 | CvGV(cv) = gv; |
08e37985 |
181 | #else |
182 | CvGV_set(cv, gv); |
183 | #endif |
16c23894 |
184 | PUSHs(sub); |