X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=Name.xs;h=a8f66f67046f30be58f7d5db19a65605253c69ed;hb=refs%2Fheads%2Fexotic-db-sub-fix;hp=9b38b050a14662c2e67a18223b15764e2fdca70a;hpb=65b620ddc50aeaecea9945eeeaf971909cf6e963;p=p5sagit%2FSub-Name.git diff --git a/Name.xs b/Name.xs index 9b38b05..a8f66f6 100644 --- a/Name.xs +++ b/Name.xs @@ -1,4 +1,5 @@ /* 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. */ @@ -6,6 +7,10 @@ #include "EXTERN.h" #include "perl.h" #include "XSUB.h" +#define NEED_sv_2pv_flags +#define NEED_newSVpvn_flags +#define NEED_gv_fetchpvn_flags +#include "ppport.h" static MGVTBL subname_vtbl; @@ -17,6 +22,33 @@ static MGVTBL subname_vtbl; #define SvMAGIC_set(sv, val) (SvMAGIC(sv) = (val)) #endif +#ifndef Newxz +#define Newxz(ptr, num, type) Newz(0, ptr, num, type) +#endif + +#ifndef HvNAMELEN_get +#define HvNAMELEN_get(stash) strlen(HvNAME(stash)) +#endif + +#ifndef HvNAMEUTF8 +#define HvNAMEUTF8(stash) 0 +#endif + +#ifndef GvNAMEUTF8 +#ifdef GvNAME_HEK +#define GvNAMEUTF8(stash) HEK_UTF8(GvNAME_HEK(gv)) +#else +#define GvNAMEUTF8(stash) 0 +#endif +#endif + +#ifndef SV_CATUTF8 +#define SV_CATUTF8 0 +#endif + +#ifndef SV_CATBYTES +#define SV_CATBYTES 0 +#endif MODULE = Sub::Name PACKAGE = Sub::Name @@ -24,13 +56,18 @@ PROTOTYPES: DISABLE void subname(name, sub) - char *name + SV *name SV *sub PREINIT: CV *cv = NULL; GV *gv; HV *stash = CopSTASH(PL_curcop); - char *s, *end = NULL, saved; + const char *s, *end = NULL, *begin = NULL; + MAGIC *mg; + STRLEN namelen; + const char* nameptr = SvPV(name, namelen); + int utf8flag = SvUTF8(name); + int seen_quote = 0, need_subst = 0; PPCODE: if (!SvROK(sub) && SvGMAGICAL(sub)) mg_get(sub); @@ -43,50 +80,102 @@ subname(name, sub) 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))) + 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 = name; *s++; ) { - if (*s == ':' && s[-1] == ':') - end = ++s; - else if (*s && s[-1] == '\'') - end = s; + + for (s = nameptr; s <= nameptr + namelen; s++) { + if (s > nameptr && *s == ':' && s[-1] == ':') { + end = s - 1; + begin = ++s; + if (seen_quote) + need_subst++; + } + else if (s > nameptr && *s != '\0' && s[-1] == '\'') { + end = s - 1; + begin = s; + if (seen_quote++) + need_subst++; + } } s--; if (end) { - saved = *end; - *end = 0; - stash = GvHV(gv_fetchpv(name, TRUE, SVt_PVHV)); - *end = saved; - name = end; + SV* tmp; + if (need_subst) { + STRLEN length = end - nameptr + seen_quote - (*end == '\'' ? 1 : 0); + char* left; + int i, j; + tmp = newSV(length); + left = SvPVX(tmp); + for (i = 0, j = 0; j < end - nameptr; ++i, ++j) { + if (nameptr[j] == '\'') { + left[i] = ':'; + left[++i] = ':'; + } + else { + left[i] = nameptr[j]; + } + } + stash = gv_stashpvn(left, length, GV_ADD | utf8flag); + SvREFCNT_dec(tmp); + } + else + stash = gv_stashpvn(nameptr, end - nameptr, GV_ADD | utf8flag); + nameptr = begin; + namelen -= begin - nameptr; } - 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); + + /* under debugger, provide information about sub location */ + if (PL_DBsub && CvGV(cv)) { + HV* DBsub = GvHV(PL_DBsub); + HE* old_data; + + GV* oldgv = CvGV(cv); + HV* oldhv = GvSTASH(oldgv); + SV* old_full_name = newSVpvn_flags(HvNAME(oldhv), HvNAMELEN_get(oldhv), HvNAMEUTF8(oldhv) ? SVf_UTF8 : 0); + sv_catpvn(old_full_name, "::", 2); + sv_catpvn_flags(old_full_name, GvNAME(oldgv), GvNAMELEN(oldgv), GvNAMEUTF8(oldgv) ? SV_CATUTF8 : SV_CATBYTES); + + old_data = hv_fetch_ent(DBsub, old_full_name, 0, 0); + + SvREFCNT_dec(old_full_name); + + if (old_data && HeVAL(old_data)) { + SV* new_full_name = newSVpvn_flags(HvNAME(stash), HvNAMELEN_get(stash), HvNAMEUTF8(stash) ? SVf_UTF8 : 0); + sv_catpvn(new_full_name, "::", 2); + sv_catpvn_flags(new_full_name, nameptr, s - nameptr, utf8flag ? SV_CATUTF8 : SV_CATBYTES); + SvREFCNT_inc(HeVAL(old_data)); + if (hv_store_ent(DBsub, new_full_name, HeVAL(old_data), 0) != NULL) + SvREFCNT_inc(HeVAL(old_data)); + SvREFCNT_dec(new_full_name); } - if (mg->mg_flags & MGf_REFCOUNTED) - SvREFCNT_dec(mg->mg_obj); - mg->mg_flags |= MGf_REFCOUNTED; - mg->mg_obj = (SV *) gv; } + + 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);