1 /* Copyright (C) 2004, 2008 Matthijs van Duin. All rights reserved.
2 * This program is free software; you can redistribute it and/or modify
3 * it under the same terms as Perl itself.
10 static MGVTBL subname_vtbl;
12 #ifndef PERL_MAGIC_ext
13 # define PERL_MAGIC_ext '~'
17 #define SvMAGIC_set(sv, val) (SvMAGIC(sv) = (val))
21 MODULE = Sub::Name PACKAGE = Sub::Name
32 HV *stash = CopSTASH(PL_curcop);
33 char *s, *end = NULL, saved;
35 if (!SvROK(sub) && SvGMAGICAL(sub))
38 cv = (CV *) SvRV(sub);
39 else if (SvTYPE(sub) == SVt_PVGV)
42 croak(PL_no_usym, "a subroutine");
43 else if (PL_op->op_private & HINT_STRICT_REFS)
44 croak(PL_no_symref, SvPV_nolen(sub), "a subroutine");
45 else if ((gv = gv_fetchpv(SvPV_nolen(sub), FALSE, SVt_PVCV)))
48 croak("Undefined subroutine %s", SvPV_nolen(sub));
49 if (SvTYPE(cv) != SVt_PVCV && SvTYPE(cv) != SVt_PVFM)
50 croak("Not a subroutine reference");
51 for (s = name; *s++; ) {
52 if (*s == ':' && s[-1] == ':')
54 else if (*s && s[-1] == '\'')
61 stash = GvHV(gv_fetchpv(name, TRUE, SVt_PVHV));
66 gv_init(gv, stash, name, s - name, TRUE);
67 #ifndef USE_5005THREADS
69 /* cheap way to refcount the gv */
70 av_store((AV *) AvARRAY(CvPADLIST(cv))[0], 0, (SV *) gv);
74 /* expensive way to refcount the gv */
75 MAGIC *mg = SvMAGIC(cv);
76 while (mg && mg->mg_virtual != &subname_vtbl)
77 mg = mg->mg_moremagic;
79 Newz(702, mg, 1, MAGIC);
80 mg->mg_moremagic = SvMAGIC(cv);
81 mg->mg_type = PERL_MAGIC_ext;
82 mg->mg_virtual = &subname_vtbl;
85 if (mg->mg_flags & MGf_REFCOUNTED)
86 SvREFCNT_dec(mg->mg_obj);
87 mg->mg_flags |= MGf_REFCOUNTED;
88 mg->mg_obj = (SV *) gv;