Skip debugging code on perls that don't need it

[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"
#define NEED_sv_2pv_flags
#define NEED_gv_fetchpvn_flags
#include "ppport.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)
	SV *name
	SV *sub
    PREINIT:
	CV *cv = NULL;
	GV *gv;
	HV *stash = CopSTASH(PL_curcop);
	const char *s, *end = NULL;
	MAGIC *mg;
	STRLEN namelen;
	int utf8flag = SvUTF8(name);
	const char* nameptr = SvPV(name, namelen);
    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_fetchsv(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 = nameptr; s <= nameptr + namelen; s++) {
		if (*s == ':' && s[-1] == ':')
			end = ++s;
		else if (*s && s[-1] == '\'')
			end = s;
	}
	s--;
	if (end) {
		stash = GvHV(gv_fetchpvn_flags(nameptr, end - nameptr, GV_ADD | utf8flag, SVt_PVHV));
		nameptr = end;
		namelen -= end - nameptr;
	}

	#ifdef PERL_VERSION < 10
	/* under debugger, provide information about sub location */
	if (PL_DBsub && CvGV(cv)) {
		HV *hv = GvHV(PL_DBsub);
		SV** old_data;

		char* new_pkg = HvNAME(stash);

		char* old_name = GvNAME( CvGV(cv) );
		char* old_pkg = HvNAME( GvSTASH(CvGV(cv)) );

		int old_len = strlen(old_name) + strlen(old_pkg);
		int new_len = namelen + strlen(new_pkg);

		char* full_name;
		Newxz(full_name, (old_len > new_len ? old_len : new_len) + 3, char);

		strcat(full_name, old_pkg);
		strcat(full_name, "::");
		strcat(full_name, old_name);

		old_data = hv_fetch(hv, full_name, strlen(full_name), 0);

		if (old_data) {
			strcpy(full_name, new_pkg);
			strcat(full_name, "::");
			strcat(full_name, nameptr);

			SvREFCNT_inc(*old_data);
			if (!hv_store(hv, full_name, strlen(full_name), *old_data, 0))
				SvREFCNT_dec(*old_data);
		}
		Safefree(full_name);
	}
	#endif

	gv = (GV *) newSV(0);
	gv_init_pvn(gv, stash, nameptr, s - nameptr, GV_ADDMULTI | utf8flag);

	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);