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

/* $Id: Name.xs,v 1.5 2004/08/18 13:21:44 xmath Exp $
 * Copyright (C) 2004  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"

#ifdef USE_5005THREADS
#error "Not compatible with 5.005 threads"
#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(PL_no_symref, 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);
	av_store((AV *) AvARRAY(CvPADLIST(cv))[0], 0, (SV *) gv);
	CvGV(cv) = gv;
	PUSHs(sub);
Commit	Line	Data
16c23894	1	/* $Id: Name.xs,v 1.5 2004/08/18 13:21:44 xmath Exp $
	2	* Copyright (C) 2004 Matthijs van Duin. All rights reserved.
	3	* This program is free software; you can redistribute it and/or modify
	4	* it under the same terms as Perl itself.
	5	*/
	6
	7	#include "EXTERN.h"
	8	#include "perl.h"
	9	#include "XSUB.h"
	10
	11	#ifdef USE_5005THREADS
	12	#error "Not compatible with 5.005 threads"
	13	#endif
	14
	15	MODULE = Sub::Name PACKAGE = Sub::Name
	16
	17	PROTOTYPES: DISABLE
	18
	19	void
	20	subname(name, sub)
	21	char *name
	22	SV *sub
	23	PREINIT:
	24	CV *cv = NULL;
	25	GV *gv;
	26	HV *stash = CopSTASH(PL_curcop);
	27	char s, end = NULL, saved;
	28	PPCODE:
	29	if (!SvROK(sub) && SvGMAGICAL(sub))
	30	mg_get(sub);
	31	if (SvROK(sub))
	32	cv = (CV *) SvRV(sub);
	33	else if (SvTYPE(sub) == SVt_PVGV)
	34	cv = GvCVu(sub);
	35	else if (!SvOK(sub))
	36	croak(PL_no_usym, "a subroutine");
	37	else if (PL_op->op_private & HINT_STRICT_REFS)
	38	croak(PL_no_symref, SvPV_nolen(sub), "a subroutine");
	39	else if ((gv = gv_fetchpv(SvPV_nolen(sub), FALSE, SVt_PVCV)))
	40	cv = GvCVu(gv);
	41	if (!cv)
	42	croak("Undefined subroutine %s", SvPV_nolen(sub));
	43	if (SvTYPE(cv) != SVt_PVCV && SvTYPE(cv) != SVt_PVFM)
	44	croak("Not a subroutine reference");
	45	for (s = name; *s++; ) {
	46	if (*s == ':' && s[-1] == ':')
	47	end = ++s;
	48	else if (*s && s[-1] == '\'')
	49	end = s;
	50	}
	51	s--;
	52	if (end) {
	53	saved = *end;
	54	*end = 0;
	55	stash = GvHV(gv_fetchpv(name, TRUE, SVt_PVHV));
	56	*end = saved;
	57	name = end;
	58	}
	59	gv = (GV *) newSV(0);
	60	gv_init(gv, stash, name, s - name, TRUE);
	61	av_store((AV ) AvARRAY(CvPADLIST(cv))[0], 0, (SV ) gv);
	62	CvGV(cv) = gv;
	63	PUSHs(sub);