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" |
10 | |
bbd01306 |
11 | static MGVTBL subname_vtbl; |
16c23894 |
12 | |
979516cc |
13 | #ifndef PERL_MAGIC_ext |
14 | # define PERL_MAGIC_ext '~' |
15 | #endif |
16 | |
17 | #ifndef SvMAGIC_set |
18 | #define SvMAGIC_set(sv, val) (SvMAGIC(sv) = (val)) |
19 | #endif |
20 | |
bcbff2c1 |
21 | #ifndef Newxz |
22 | #define Newxz(ptr, num, type) Newz(0, ptr, num, type) |
23 | #endif |
979516cc |
24 | |
16c23894 |
25 | MODULE = Sub::Name PACKAGE = Sub::Name |
26 | |
27 | PROTOTYPES: DISABLE |
28 | |
29 | void |
30 | subname(name, sub) |
31 | char *name |
32 | SV *sub |
33 | PREINIT: |
34 | CV *cv = NULL; |
35 | GV *gv; |
36 | HV *stash = CopSTASH(PL_curcop); |
24f50a79 |
37 | char *s, *end = NULL; |
fa213968 |
38 | MAGIC *mg; |
16c23894 |
39 | PPCODE: |
40 | if (!SvROK(sub) && SvGMAGICAL(sub)) |
41 | mg_get(sub); |
42 | if (SvROK(sub)) |
43 | cv = (CV *) SvRV(sub); |
44 | else if (SvTYPE(sub) == SVt_PVGV) |
45 | cv = GvCVu(sub); |
46 | else if (!SvOK(sub)) |
47 | croak(PL_no_usym, "a subroutine"); |
48 | else if (PL_op->op_private & HINT_STRICT_REFS) |
65b620dd |
49 | croak("Can't use string (\"%.32s\") as %s ref while \"strict refs\" in use", |
50 | SvPV_nolen(sub), "a subroutine"); |
16c23894 |
51 | else if ((gv = gv_fetchpv(SvPV_nolen(sub), FALSE, SVt_PVCV))) |
52 | cv = GvCVu(gv); |
53 | if (!cv) |
54 | croak("Undefined subroutine %s", SvPV_nolen(sub)); |
55 | if (SvTYPE(cv) != SVt_PVCV && SvTYPE(cv) != SVt_PVFM) |
56 | croak("Not a subroutine reference"); |
57 | for (s = name; *s++; ) { |
58 | if (*s == ':' && s[-1] == ':') |
59 | end = ++s; |
60 | else if (*s && s[-1] == '\'') |
61 | end = s; |
62 | } |
63 | s--; |
24f50a79 |
64 | if (end) { |
85cf5fae |
65 | char *namepv = savepvn(name, end - name); |
66 | stash = GvHV(gv_fetchpv(namepv, TRUE, SVt_PVHV)); |
67 | Safefree(namepv); |
24f50a79 |
68 | name = end; |
69 | } |
3967e628 |
70 | |
71 | /* under debugger, provide information about sub location */ |
72 | if (PL_DBsub && CvGV(cv)) { |
73 | HV *hv = GvHV(PL_DBsub); |
74 | |
75 | char* new_pkg = HvNAME(stash); |
76 | |
77 | char* old_name = GvNAME( CvGV(cv) ); |
78 | char* old_pkg = HvNAME( GvSTASH(CvGV(cv)) ); |
79 | |
80 | int old_len = strlen(old_name) + strlen(old_pkg); |
81 | int new_len = strlen(name) + strlen(new_pkg); |
82 | |
83 | char* full_name; |
84 | Newxz(full_name, (old_len > new_len ? old_len : new_len) + 3, char); |
85 | |
86 | strcat(full_name, old_pkg); |
87 | strcat(full_name, "::"); |
88 | strcat(full_name, old_name); |
89 | |
90 | SV** old_data = hv_fetch(hv, full_name, strlen(full_name), 0); |
91 | |
92 | if (old_data) { |
93 | strcpy(full_name, new_pkg); |
94 | strcat(full_name, "::"); |
95 | strcat(full_name, name); |
96 | |
97 | SvREFCNT_inc(*old_data); |
98 | if (!hv_store(hv, full_name, strlen(full_name), *old_data, 0)) |
99 | SvREFCNT_dec(*old_data); |
100 | } |
101 | Safefree(full_name); |
102 | } |
103 | |
16c23894 |
104 | gv = (GV *) newSV(0); |
105 | gv_init(gv, stash, name, s - name, TRUE); |
fa213968 |
106 | |
107 | mg = SvMAGIC(cv); |
108 | while (mg && mg->mg_virtual != &subname_vtbl) |
109 | mg = mg->mg_moremagic; |
110 | if (!mg) { |
bcbff2c1 |
111 | Newxz(mg, 1, MAGIC); |
fa213968 |
112 | mg->mg_moremagic = SvMAGIC(cv); |
113 | mg->mg_type = PERL_MAGIC_ext; |
114 | mg->mg_virtual = &subname_vtbl; |
115 | SvMAGIC_set(cv, mg); |
bbd01306 |
116 | } |
fa213968 |
117 | if (mg->mg_flags & MGf_REFCOUNTED) |
118 | SvREFCNT_dec(mg->mg_obj); |
119 | mg->mg_flags |= MGf_REFCOUNTED; |
120 | mg->mg_obj = (SV *) gv; |
5804808d |
121 | SvRMAGICAL_on(cv); |
122 | CvANON_off(cv); |
08e37985 |
123 | #ifndef CvGV_set |
16c23894 |
124 | CvGV(cv) = gv; |
08e37985 |
125 | #else |
126 | CvGV_set(cv, gv); |
127 | #endif |
16c23894 |
128 | PUSHs(sub); |