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. 4 */ 5 6#include "EXTERN.h" 7#include "perl.h" 8#include "XSUB.h" 9 10static MGVTBL subname_vtbl; 11 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 21MODULE = Sub::Name PACKAGE = Sub::Name 22 23PROTOTYPES: DISABLE 24 25void 26subname(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; 34 PPCODE: 35 if (!SvROK(sub) && SvGMAGICAL(sub)) 36 mg_get(sub); 37 if (SvROK(sub)) 38 cv = (CV *) SvRV(sub); 39 else if (SvTYPE(sub) == SVt_PVGV) 40 cv = GvCVu(sub); 41 else if (!SvOK(sub)) 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))) 46 cv = GvCVu(gv); 47 if (!cv) 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] == ':') 53 end = ++s; 54 else if (*s && s[-1] == '\'') 55 end = s; 56 } 57 s--; 58 if (end) { 59 saved = *end; 60 *end = 0; 61 stash = GvHV(gv_fetchpv(name, TRUE, SVt_PVHV)); 62 *end = saved; 63 name = end; 64 } 65 gv = (GV *) newSV(0); 66 gv_init(gv, stash, name, s - name, TRUE); 67#ifndef USE_5005THREADS 68 if (CvPADLIST(cv)) { 69 /* cheap way to refcount the gv */ 70 av_store((AV *) AvARRAY(CvPADLIST(cv))[0], 0, (SV *) gv); 71 } else 72#endif 73 { 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; 78 if (!mg) { 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; 83 SvMAGIC_set(cv, mg); 84 } 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; 89 } 90 CvGV(cv) = gv; 91 PUSHs(sub); 92