X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=Name.xs;h=9a4d4939872749b2d634a019a76b5dd8d16dd361;hb=4a3201daca5022e50a4ce0ab36016a5a7ed76c96;hp=58342a918358f6330425e3b0f838755130739f53;hpb=a158e3c12ec8c00ccb36adda31344e5ffccf9fae;p=p5sagit%2FSub-Name.git diff --git a/Name.xs b/Name.xs index 58342a9..9a4d493 100644 --- a/Name.xs +++ b/Name.xs @@ -37,11 +37,12 @@ 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 seen_quote = 0, need_subst = 0; PPCODE: if (!SvROK(sub) && SvGMAGICAL(sub)) mg_get(sub); @@ -62,16 +63,44 @@ 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 (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) { - 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 + 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; } #ifdef PERL_VERSION < 10