X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=Name.xs;h=4957c3592ca0c21bcdec407524495f38cc22be9c;hb=ether%2Fsingle-quote-removed;hp=58342a918358f6330425e3b0f838755130739f53;hpb=a158e3c12ec8c00ccb36adda31344e5ffccf9fae;p=p5sagit%2FSub-Name.git diff --git a/Name.xs b/Name.xs index 58342a9..4957c35 100644 --- a/Name.xs +++ b/Name.xs @@ -8,7 +8,10 @@ #include "perl.h" #include "XSUB.h" #define NEED_sv_2pv_flags +#define NEED_newSVpvn_flags #define NEED_gv_fetchpvn_flags +#define NEED_sv_catpvn_flags +#define NEED_croak_xs_usage /* running `perl ppport.h Name.xs` suggests removing this, but don't! see RT#125158 */ #include "ppport.h" static MGVTBL subname_vtbl; @@ -25,6 +28,34 @@ static MGVTBL subname_vtbl; #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(gv) HEK_UTF8(GvNAME_HEK(gv)) +#else +#define GvNAMEUTF8(gv) 0 +#endif +#endif + +#ifndef SV_CATUTF8 +#define SV_CATUTF8 0 +#endif + +#ifndef SV_CATBYTES +#define SV_CATBYTES 0 +#endif + +#ifndef sv_catpvn_flags +#define sv_catpvn_flags(b,n,l,f) sv_catpvn(b,n,l) +#endif + MODULE = Sub::Name PACKAGE = Sub::Name PROTOTYPES: DISABLE @@ -37,11 +68,13 @@ subname(name, sub) CV *cv = NULL; GV *gv; HV *stash = CopSTASH(PL_curcop); - const char *s, *end = NULL; + const char *s, *end = NULL, *begin = NULL; MAGIC *mg; STRLEN namelen; - int utf8flag = SvUTF8(name); const char* nameptr = SvPV(name, namelen); + int utf8flag = SvUTF8(name); + int quotes_seen = 0; + bool need_subst = FALSE; PPCODE: if (!SvROK(sub) && SvGMAGICAL(sub)) mg_get(sub); @@ -62,53 +95,67 @@ subname(name, sub) 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; + if (s > nameptr && *s == ':' && s[-1] == ':') { + end = s - 1; + begin = ++s; + if (quotes_seen) + need_subst = TRUE; + } + else if (s > nameptr && *s != '\0' && s[-1] == '\'') { + end = s - 1; + begin = s; + if (quotes_seen++) + need_subst = TRUE; + } } s--; if (end) { - stash = GvHV(gv_fetchpvn_flags(nameptr, end - nameptr, GV_ADD | utf8flag, SVt_PVHV)); - nameptr = end; - namelen -= end - nameptr; + SV* tmp; + if (need_subst) { + STRLEN length = end - nameptr + quotes_seen - (*end == '\'' ? 1 : 0); + char* left; + int i, j; + tmp = sv_2mortal(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); + } + else + stash = gv_stashpvn(nameptr, end - nameptr, GV_ADD | utf8flag); + nameptr = begin; + namelen -= begin - 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); + HV* DBsub = GvHV(PL_DBsub); + HE* old_data; + + GV* oldgv = CvGV(cv); + HV* oldhv = GvSTASH(oldgv); + SV* old_full_name = sv_2mortal(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); + + if (old_data && HeVAL(old_data)) { + SV* new_full_name = sv_2mortal(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)); } - Safefree(full_name); } - #endif gv = (GV *) newSV(0); gv_init_pvn(gv, stash, nameptr, s - nameptr, GV_ADDMULTI | utf8flag);