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 |
11 | #define NEED_gv_fetchpvn_flags |
3b02e094 |
12 | #include "ppport.h" |
16c23894 |
13 | |
bbd01306 |
14 | static MGVTBL subname_vtbl; |
16c23894 |
15 | |
979516cc |
16 | #ifndef PERL_MAGIC_ext |
17 | # define PERL_MAGIC_ext '~' |
18 | #endif |
19 | |
20 | #ifndef SvMAGIC_set |
21 | #define SvMAGIC_set(sv, val) (SvMAGIC(sv) = (val)) |
22 | #endif |
23 | |
bcbff2c1 |
24 | #ifndef Newxz |
25 | #define Newxz(ptr, num, type) Newz(0, ptr, num, type) |
26 | #endif |
979516cc |
27 | |
16c23894 |
28 | MODULE = Sub::Name PACKAGE = Sub::Name |
29 | |
30 | PROTOTYPES: DISABLE |
31 | |
32 | void |
33 | subname(name, sub) |
eb7c69cd |
34 | SV *name |
16c23894 |
35 | SV *sub |
36 | PREINIT: |
37 | CV *cv = NULL; |
38 | GV *gv; |
39 | HV *stash = CopSTASH(PL_curcop); |
12e89eea |
40 | const char *s, *end = NULL, *begin = NULL; |
fa213968 |
41 | MAGIC *mg; |
eb7c69cd |
42 | STRLEN namelen; |
43 | int utf8flag = SvUTF8(name); |
44 | const char* nameptr = SvPV(name, namelen); |
12e89eea |
45 | int seen_quote = 0, need_subst = 0; |
16c23894 |
46 | PPCODE: |
47 | if (!SvROK(sub) && SvGMAGICAL(sub)) |
48 | mg_get(sub); |
49 | if (SvROK(sub)) |
50 | cv = (CV *) SvRV(sub); |
51 | else if (SvTYPE(sub) == SVt_PVGV) |
52 | cv = GvCVu(sub); |
53 | else if (!SvOK(sub)) |
54 | croak(PL_no_usym, "a subroutine"); |
55 | else if (PL_op->op_private & HINT_STRICT_REFS) |
65b620dd |
56 | croak("Can't use string (\"%.32s\") as %s ref while \"strict refs\" in use", |
57 | SvPV_nolen(sub), "a subroutine"); |
eb7c69cd |
58 | else if ((gv = gv_fetchsv(sub, FALSE, SVt_PVCV))) |
16c23894 |
59 | cv = GvCVu(gv); |
60 | if (!cv) |
61 | croak("Undefined subroutine %s", SvPV_nolen(sub)); |
62 | if (SvTYPE(cv) != SVt_PVCV && SvTYPE(cv) != SVt_PVFM) |
63 | croak("Not a subroutine reference"); |
eb7c69cd |
64 | |
65 | for (s = nameptr; s <= nameptr + namelen; s++) { |
12e89eea |
66 | if (*s == ':' && s[-1] == ':') { |
67 | end = s - 1; |
68 | begin = ++s; |
69 | if (seen_quote) |
9f60da16 |
70 | need_subst++; |
12e89eea |
71 | } |
72 | else if (*s && s[-1] == '\'') { |
73 | end = s - 1; |
74 | begin = s; |
9f60da16 |
75 | if (seen_quote++) |
76 | need_subst++; |
12e89eea |
77 | } |
16c23894 |
78 | } |
79 | s--; |
eb7c69cd |
80 | if (end) { |
12e89eea |
81 | SV* tmp; |
9f60da16 |
82 | if (need_subst) { |
83 | STRLEN length = end - nameptr + seen_quote - (*end == '\'' ? 1 : 0); |
12e89eea |
84 | char* left; |
85 | int i, j; |
86 | tmp = newSV(length); |
87 | left = SvPVX(tmp); |
9f60da16 |
88 | for (i = 0, j = 0; j < end - nameptr; ++i, ++j) { |
12e89eea |
89 | if (nameptr[j] == '\'') { |
90 | left[i] = ':'; |
91 | left[++i] = ':'; |
92 | } |
93 | else { |
94 | left[i] = nameptr[j]; |
95 | } |
96 | } |
9f60da16 |
97 | stash = gv_stashpvn(left, length, GV_ADD | utf8flag); |
12e89eea |
98 | SvREFCNT_dec(tmp); |
99 | } |
100 | else |
101 | stash = gv_stashpvn(nameptr, end - nameptr, GV_ADD | utf8flag); |
102 | nameptr = begin; |
103 | namelen -= begin - nameptr; |
eb7c69cd |
104 | } |
3967e628 |
105 | |
a158e3c1 |
106 | #ifdef PERL_VERSION < 10 |
3967e628 |
107 | /* under debugger, provide information about sub location */ |
108 | if (PL_DBsub && CvGV(cv)) { |
109 | HV *hv = GvHV(PL_DBsub); |
a89f3975 |
110 | SV** old_data; |
0266da0f |
111 | |
3967e628 |
112 | char* new_pkg = HvNAME(stash); |
113 | |
114 | char* old_name = GvNAME( CvGV(cv) ); |
115 | char* old_pkg = HvNAME( GvSTASH(CvGV(cv)) ); |
116 | |
117 | int old_len = strlen(old_name) + strlen(old_pkg); |
eb7c69cd |
118 | int new_len = namelen + strlen(new_pkg); |
3967e628 |
119 | |
120 | char* full_name; |
121 | Newxz(full_name, (old_len > new_len ? old_len : new_len) + 3, char); |
122 | |
123 | strcat(full_name, old_pkg); |
124 | strcat(full_name, "::"); |
125 | strcat(full_name, old_name); |
126 | |
a89f3975 |
127 | old_data = hv_fetch(hv, full_name, strlen(full_name), 0); |
3967e628 |
128 | |
129 | if (old_data) { |
130 | strcpy(full_name, new_pkg); |
131 | strcat(full_name, "::"); |
eb7c69cd |
132 | strcat(full_name, nameptr); |
3967e628 |
133 | |
134 | SvREFCNT_inc(*old_data); |
135 | if (!hv_store(hv, full_name, strlen(full_name), *old_data, 0)) |
136 | SvREFCNT_dec(*old_data); |
137 | } |
138 | Safefree(full_name); |
139 | } |
a158e3c1 |
140 | #endif |
3967e628 |
141 | |
16c23894 |
142 | gv = (GV *) newSV(0); |
eb7c69cd |
143 | gv_init_pvn(gv, stash, nameptr, s - nameptr, GV_ADDMULTI | utf8flag); |
fa213968 |
144 | |
145 | mg = SvMAGIC(cv); |
146 | while (mg && mg->mg_virtual != &subname_vtbl) |
147 | mg = mg->mg_moremagic; |
148 | if (!mg) { |
bcbff2c1 |
149 | Newxz(mg, 1, MAGIC); |
fa213968 |
150 | mg->mg_moremagic = SvMAGIC(cv); |
151 | mg->mg_type = PERL_MAGIC_ext; |
152 | mg->mg_virtual = &subname_vtbl; |
153 | SvMAGIC_set(cv, mg); |
bbd01306 |
154 | } |
fa213968 |
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; |
5804808d |
159 | SvRMAGICAL_on(cv); |
160 | CvANON_off(cv); |
08e37985 |
161 | #ifndef CvGV_set |
16c23894 |
162 | CvGV(cv) = gv; |
08e37985 |
163 | #else |
164 | CvGV_set(cv, gv); |
165 | #endif |
16c23894 |
166 | PUSHs(sub); |