Fix RT#96893 - do not change the string arg in XS; use a copy instead (problem under...
[p5sagit/Sub-Name.git] / Name.xs
CommitLineData
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 11static 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
21
16c23894 22MODULE = Sub::Name PACKAGE = Sub::Name
23
24PROTOTYPES: DISABLE
25
26void
27subname(name, sub)
28 char *name
29 SV *sub
30 PREINIT:
31 CV *cv = NULL;
32 GV *gv;
33 HV *stash = CopSTASH(PL_curcop);
24f50a79 34 char *s, *end = NULL;
fa213968 35 MAGIC *mg;
16c23894 36 PPCODE:
37 if (!SvROK(sub) && SvGMAGICAL(sub))
38 mg_get(sub);
39 if (SvROK(sub))
40 cv = (CV *) SvRV(sub);
41 else if (SvTYPE(sub) == SVt_PVGV)
42 cv = GvCVu(sub);
43 else if (!SvOK(sub))
44 croak(PL_no_usym, "a subroutine");
45 else if (PL_op->op_private & HINT_STRICT_REFS)
65b620dd 46 croak("Can't use string (\"%.32s\") as %s ref while \"strict refs\" in use",
47 SvPV_nolen(sub), "a subroutine");
16c23894 48 else if ((gv = gv_fetchpv(SvPV_nolen(sub), FALSE, SVt_PVCV)))
49 cv = GvCVu(gv);
50 if (!cv)
51 croak("Undefined subroutine %s", SvPV_nolen(sub));
52 if (SvTYPE(cv) != SVt_PVCV && SvTYPE(cv) != SVt_PVFM)
53 croak("Not a subroutine reference");
54 for (s = name; *s++; ) {
55 if (*s == ':' && s[-1] == ':')
56 end = ++s;
57 else if (*s && s[-1] == '\'')
58 end = s;
59 }
60 s--;
24f50a79 61 if (end) {
62 stash = GvHV(gv_fetchpv(savepvn(name, end - name), TRUE, SVt_PVHV));
63 name = end;
64 }
16c23894 65 gv = (GV *) newSV(0);
66 gv_init(gv, stash, name, s - name, TRUE);
fa213968 67
68 mg = SvMAGIC(cv);
69 while (mg && mg->mg_virtual != &subname_vtbl)
70 mg = mg->mg_moremagic;
71 if (!mg) {
72 Newz(702, mg, 1, MAGIC);
73 mg->mg_moremagic = SvMAGIC(cv);
74 mg->mg_type = PERL_MAGIC_ext;
75 mg->mg_virtual = &subname_vtbl;
76 SvMAGIC_set(cv, mg);
bbd01306 77 }
fa213968 78 if (mg->mg_flags & MGf_REFCOUNTED)
79 SvREFCNT_dec(mg->mg_obj);
80 mg->mg_flags |= MGf_REFCOUNTED;
81 mg->mg_obj = (SV *) gv;
5804808d 82 SvRMAGICAL_on(cv);
83 CvANON_off(cv);
08e37985 84#ifndef CvGV_set
16c23894 85 CvGV(cv) = gv;
08e37985 86#else
87 CvGV_set(cv, gv);
88#endif
16c23894 89 PUSHs(sub);