[p5sagit/Sub-Name.git] / Name.xs

/* Copyright (C) 2004, 2008  Matthijs van Duin.  All rights reserved.
 * This program is free software; you can redistribute it and/or modify
 * it under the same terms as Perl itself.
 */

#include "EXTERN.h"
#include "perl.h"
#include "XSUB.h"

static MGVTBL subname_vtbl;

#ifndef PERL_MAGIC_ext
# define PERL_MAGIC_ext '~'
#endif

#ifndef SvMAGIC_set
#define SvMAGIC_set(sv, val) (SvMAGIC(sv) = (val))
#endif


MODULE = Sub::Name  PACKAGE = Sub::Name

PROTOTYPES: DISABLE

void
subname(name, sub)
	char *name
	SV *sub
    PREINIT:
	CV *cv = NULL;
	GV *gv;
	HV *stash = CopSTASH(PL_curcop);
	char *s, *end = NULL, saved;
    PPCODE:
	if (!SvROK(sub) && SvGMAGICAL(sub))
		mg_get(sub);
	if (SvROK(sub))
		cv = (CV *) SvRV(sub);
	else if (SvTYPE(sub) == SVt_PVGV)
		cv = GvCVu(sub);
	else if (!SvOK(sub))
		croak(PL_no_usym, "a subroutine");
	else if (PL_op->op_private & HINT_STRICT_REFS)
		croak("Can't use string (\"%.32s\") as %s ref while \"strict refs\" in use",
		      SvPV_nolen(sub), "a subroutine");
	else if ((gv = gv_fetchpv(SvPV_nolen(sub), FALSE, SVt_PVCV)))
		cv = GvCVu(gv);
	if (!cv)
		croak("Undefined subroutine %s", SvPV_nolen(sub));
	if (SvTYPE(cv) != SVt_PVCV && SvTYPE(cv) != SVt_PVFM)
		croak("Not a subroutine reference");
	for (s = name; *s++; ) {
		if (*s == ':' && s[-1] == ':')
			end = ++s;
		else if (*s && s[-1] == '\'')
			end = s;
	}
	s--;
	if (end) {
		saved = *end;
		*end = 0;
		stash = GvHV(gv_fetchpv(name, TRUE, SVt_PVHV));
		*end = saved;
		name = end;
	}
	gv = (GV *) newSV(0);
	gv_init(gv, stash, name, s - name, TRUE);
#ifndef USE_5005THREADS
	if (CvPADLIST(cv)) {
		/* cheap way to refcount the gv */
		av_store((AV *) AvARRAY(CvPADLIST(cv))[0], 0, (SV *) gv);
	} else
#endif
	{
		/* expensive way to refcount the gv */
		MAGIC *mg = SvMAGIC(cv);
		while (mg && mg->mg_virtual != &subname_vtbl)
			mg = mg->mg_moremagic;
		if (!mg) {
			Newz(702, mg, 1, MAGIC);
			mg->mg_moremagic = SvMAGIC(cv);
			mg->mg_type = PERL_MAGIC_ext;
			mg->mg_virtual = &subname_vtbl;
			SvMAGIC_set(cv, mg);
		}
		if (mg->mg_flags & MGf_REFCOUNTED)
			SvREFCNT_dec(mg->mg_obj);
		mg->mg_flags |= MGf_REFCOUNTED;
		mg->mg_obj = (SV *) gv;
	}
#ifndef CvGV_set
	CvGV(cv) = gv;
#else
	CvGV_set(cv, gv);
#endif
	PUSHs(sub);
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;
	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)
65b620dd	44	croak("Can't use string (\"%.32s\") as %s ref while \"strict refs\" in use",
65b620dd	45	SvPV_nolen(sub), "a subroutine");
16c23894	46	else if ((gv = gv_fetchpv(SvPV_nolen(sub), FALSE, SVt_PVCV)))
	47	cv = GvCVu(gv);
	48	if (!cv)
	49	croak("Undefined subroutine %s", SvPV_nolen(sub));
	50	if (SvTYPE(cv) != SVt_PVCV && SvTYPE(cv) != SVt_PVFM)
	51	croak("Not a subroutine reference");
	52	for (s = name; *s++; ) {
	53	if (*s == ':' && s[-1] == ':')
	54	end = ++s;
	55	else if (*s && s[-1] == '\'')
	56	end = s;
	57	}
	58	s--;
	59	if (end) {
	60	saved = *end;
	61	*end = 0;
	62	stash = GvHV(gv_fetchpv(name, TRUE, SVt_PVHV));
	63	*end = saved;
	64	name = end;
	65	}
	66	gv = (GV *) newSV(0);
	67	gv_init(gv, stash, name, s - name, TRUE);
bbd01306	68	#ifndef USE_5005THREADS
	69	if (CvPADLIST(cv)) {
	70	/* cheap way to refcount the gv */
	71	av_store((AV ) AvARRAY(CvPADLIST(cv))[0], 0, (SV ) gv);
979516cc	72	} else
bbd01306	73	#endif
979516cc	74	{
bbd01306	75	/* expensive way to refcount the gv */
	76	MAGIC *mg = SvMAGIC(cv);
	77	while (mg && mg->mg_virtual != &subname_vtbl)
	78	mg = mg->mg_moremagic;
979516cc	79	if (!mg) {
	80	Newz(702, mg, 1, MAGIC);
	81	mg->mg_moremagic = SvMAGIC(cv);
	82	mg->mg_type = PERL_MAGIC_ext;
	83	mg->mg_virtual = &subname_vtbl;
	84	SvMAGIC_set(cv, mg);
	85	}
bbd01306	86	if (mg->mg_flags & MGf_REFCOUNTED)
	87	SvREFCNT_dec(mg->mg_obj);
	88	mg->mg_flags \|= MGf_REFCOUNTED;
	89	mg->mg_obj = (SV *) gv;
	90	}
08e37985	91	#ifndef CvGV_set
16c23894	92	CvGV(cv) = gv;
08e37985	93	#else
	94	CvGV_set(cv, gv);
	95	#endif
16c23894	96	PUSHs(sub);