Commit | Line | Data |
979516cc |
1 | /* Copyright (C) 2004, 2008 Matthijs van Duin. All rights reserved. |
65b620dd |
2 | * This program is free software; you can redistribute it and/or modify |
16c23894 |
3 | * it under the same terms as Perl itself. |
4 | */ |
5 | |
6 | #include "EXTERN.h" |
7 | #include "perl.h" |
8 | #include "XSUB.h" |
9 | |
bbd01306 |
10 | static MGVTBL subname_vtbl; |
16c23894 |
11 | |
979516cc |
12 | #ifndef PERL_MAGIC_ext |
13 | # define PERL_MAGIC_ext '~' |
14 | #endif |
15 | |
16 | #ifndef SvMAGIC_set |
17 | #define SvMAGIC_set(sv, val) (SvMAGIC(sv) = (val)) |
18 | #endif |
19 | |
20 | |
16c23894 |
21 | MODULE = Sub::Name PACKAGE = Sub::Name |
22 | |
23 | PROTOTYPES: DISABLE |
24 | |
25 | void |
26 | subname(name, sub) |
27 | char *name |
28 | SV *sub |
29 | PREINIT: |
30 | CV *cv = NULL; |
31 | GV *gv; |
32 | HV *stash = CopSTASH(PL_curcop); |
33 | char *s, *end = NULL, saved; |
fa213968 |
34 | MAGIC *mg; |
16c23894 |
35 | PPCODE: |
36 | if (!SvROK(sub) && SvGMAGICAL(sub)) |
37 | mg_get(sub); |
38 | if (SvROK(sub)) |
39 | cv = (CV *) SvRV(sub); |
40 | else if (SvTYPE(sub) == SVt_PVGV) |
41 | cv = GvCVu(sub); |
42 | else if (!SvOK(sub)) |
43 | croak(PL_no_usym, "a subroutine"); |
44 | else if (PL_op->op_private & HINT_STRICT_REFS) |
65b620dd |
45 | croak("Can't use string (\"%.32s\") as %s ref while \"strict refs\" in use", |
46 | SvPV_nolen(sub), "a subroutine"); |
16c23894 |
47 | else if ((gv = gv_fetchpv(SvPV_nolen(sub), FALSE, SVt_PVCV))) |
48 | cv = GvCVu(gv); |
49 | if (!cv) |
50 | croak("Undefined subroutine %s", SvPV_nolen(sub)); |
51 | if (SvTYPE(cv) != SVt_PVCV && SvTYPE(cv) != SVt_PVFM) |
52 | croak("Not a subroutine reference"); |
53 | for (s = name; *s++; ) { |
54 | if (*s == ':' && s[-1] == ':') |
55 | end = ++s; |
56 | else if (*s && s[-1] == '\'') |
57 | end = s; |
58 | } |
59 | s--; |
60 | if (end) { |
61 | saved = *end; |
62 | *end = 0; |
63 | stash = GvHV(gv_fetchpv(name, TRUE, SVt_PVHV)); |
64 | *end = saved; |
65 | name = end; |
66 | } |
67 | gv = (GV *) newSV(0); |
68 | gv_init(gv, stash, name, s - name, TRUE); |
fa213968 |
69 | |
70 | mg = SvMAGIC(cv); |
71 | while (mg && mg->mg_virtual != &subname_vtbl) |
72 | mg = mg->mg_moremagic; |
73 | if (!mg) { |
74 | Newz(702, mg, 1, MAGIC); |
75 | mg->mg_moremagic = SvMAGIC(cv); |
76 | mg->mg_type = PERL_MAGIC_ext; |
77 | mg->mg_virtual = &subname_vtbl; |
78 | SvMAGIC_set(cv, mg); |
bbd01306 |
79 | } |
fa213968 |
80 | if (mg->mg_flags & MGf_REFCOUNTED) |
81 | SvREFCNT_dec(mg->mg_obj); |
82 | mg->mg_flags |= MGf_REFCOUNTED; |
83 | mg->mg_obj = (SV *) gv; |
08e37985 |
84 | #ifndef CvGV_set |
16c23894 |
85 | CvGV(cv) = gv; |
08e37985 |
86 | #else |
87 | CvGV_set(cv, gv); |
88 | #endif |
16c23894 |
89 | PUSHs(sub); |