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

/* Copyright (C) 2004, 2008  Matthijs van Duin.  All rights reserved.
 * Copyright (C) 2014, cPanel Inc.  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

#ifndef Newxz
#define Newxz(ptr, num, type)	Newz(0, ptr, num, type)
#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;
	MAGIC *mg;
    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) {
		char *namepv = savepvn(name, end - name);
		stash = GvHV(gv_fetchpv(namepv, TRUE, SVt_PVHV));
		Safefree(namepv);
                name = end;
        }
	gv = (GV *) newSV(0);
	gv_init(gv, stash, name, s - name, TRUE);

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