Name.xs

   1 /* Copyright (C) 2004, 2008  Matthijs van Duin.  All rights reserved.
   2  * Copyright (C) 2014, cPanel Inc.  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 #define NEED_sv_2pv_flags
  11 #define NEED_newSVpvn_flags
  12 #define NEED_gv_fetchpvn_flags
  13 #define NEED_sv_catpvn_flags
  14 #include "ppport.h"
  15
  16 static MGVTBL subname_vtbl;
  17
  18 #ifndef PERL_MAGIC_ext
  19 # define PERL_MAGIC_ext '~'
  20 #endif
  21
  22 #ifndef SvMAGIC_set
  23 #define SvMAGIC_set(sv, val) (SvMAGIC(sv) = (val))
  24 #endif
  25
  26 #ifndef Newxz
  27 #define Newxz(ptr, num, type)   Newz(0, ptr, num, type)
  28 #endif
  29
  30 #ifndef HvNAMELEN_get
  31 #define HvNAMELEN_get(stash) strlen(HvNAME(stash))
  32 #endif
  33
  34 #ifndef HvNAMEUTF8
  35 #define HvNAMEUTF8(stash) 0
  36 #endif
  37
  38 #ifndef GvNAMEUTF8
  39 #ifdef GvNAME_HEK
  40 #define GvNAMEUTF8(gv) HEK_UTF8(GvNAME_HEK(gv))
  41 #else
  42 #define GvNAMEUTF8(gv) 0
  43 #endif
  44 #endif
  45
  46 #ifndef SV_CATUTF8
  47 #define SV_CATUTF8 0
  48 #endif
  49
  50 #ifndef SV_CATBYTES
  51 #define SV_CATBYTES 0
  52 #endif
  53
  54 #ifndef sv_catpvn_flags
  55 #define sv_catpvn_flags(b,n,l,f) sv_catpvn(b,n,l)
  56 #endif
  57
  58 MODULE = Sub::Name  PACKAGE = Sub::Name
  59
  60 PROTOTYPES: DISABLE
  61
  62 void
  63 subname(name, sub)
  64         SV *name
  65         SV *sub
  66     PREINIT:
  67         CV *cv = NULL;
  68         GV *gv;
  69         HV *stash = CopSTASH(PL_curcop);
  70         const char *s, *end = NULL, *begin = NULL;
  71         MAGIC *mg;
  72         STRLEN namelen;
  73         const char* nameptr = SvPV(name, namelen);
  74         int utf8flag = SvUTF8(name);
  75         int seen_quote = 0, need_subst = 0;
  76     PPCODE:
  77         if (!SvROK(sub) && SvGMAGICAL(sub))
  78                 mg_get(sub);
  79         if (SvROK(sub))
  80                 cv = (CV *) SvRV(sub);
  81         else if (SvTYPE(sub) == SVt_PVGV)
  82                 cv = GvCVu(sub);
  83         else if (!SvOK(sub))
  84                 croak(PL_no_usym, "a subroutine");
  85         else if (PL_op->op_private & HINT_STRICT_REFS)
  86                 croak("Can't use string (\"%.32s\") as %s ref while \"strict refs\" in use",
  87                       SvPV_nolen(sub), "a subroutine");
  88         else if ((gv = gv_fetchsv(sub, FALSE, SVt_PVCV)))
  89                 cv = GvCVu(gv);
  90         if (!cv)
  91                 croak("Undefined subroutine %s", SvPV_nolen(sub));
  92         if (SvTYPE(cv) != SVt_PVCV && SvTYPE(cv) != SVt_PVFM)
  93                 croak("Not a subroutine reference");
  94
  95         for (s = nameptr; s <= nameptr + namelen; s++) {
  96                 if (s > nameptr && *s == ':' && s[-1] == ':') {
  97                         end = s - 1;
  98                         begin = ++s;
  99                         if (seen_quote)
 100                                 need_subst++;
 101                 }
 102                 else if (s > nameptr && *s != '\0' && s[-1] == '\'') {
 103                         end = s - 1;
 104                         begin = s;
 105                         if (seen_quote++)
 106                                 need_subst++;
 107                 }
 108         }
 109         s--;
 110         if (end) {
 111                 SV* tmp;
 112                 if (need_subst) {
 113                         STRLEN length = end - nameptr + seen_quote - (*end == '\'' ? 1 : 0);
 114                         char* left;
 115                         int i, j;
 116                         tmp = newSV(length);
 117                         left = SvPVX(tmp);
 118                         for (i = 0, j = 0; j < end - nameptr; ++i, ++j) {
 119                                 if (nameptr[j] == '\'') {
 120                                         left[i] = ':';
 121                                         left[++i] = ':';
 122                                 }
 123                                 else {
 124                                         left[i] = nameptr[j];
 125                                 }
 126                         }
 127                         stash = gv_stashpvn(left, length, GV_ADD | utf8flag);
 128                         SvREFCNT_dec(tmp);
 129                 }
 130                 else
 131                         stash = gv_stashpvn(nameptr, end - nameptr, GV_ADD | utf8flag);
 132                 nameptr = begin;
 133                 namelen -= begin - nameptr;
 134         }
 135
 136         /* under debugger, provide information about sub location */
 137         if (PL_DBsub && CvGV(cv)) {
 138                 HV* DBsub = GvHV(PL_DBsub);
 139                 HE* old_data;
 140
 141                 GV* oldgv = CvGV(cv);
 142                 HV* oldhv = GvSTASH(oldgv);
 143                 SV* old_full_name = newSVpvn_flags(HvNAME(oldhv), HvNAMELEN_get(oldhv), HvNAMEUTF8(oldhv) ? SVf_UTF8 : 0);
 144                 sv_catpvn(old_full_name, "::", 2);
 145                 sv_catpvn_flags(old_full_name, GvNAME(oldgv), GvNAMELEN(oldgv), GvNAMEUTF8(oldgv) ? SV_CATUTF8 : SV_CATBYTES);
 146
 147                 old_data = hv_fetch_ent(DBsub, old_full_name, 0, 0);
 148
 149                 SvREFCNT_dec(old_full_name);
 150
 151                 if (old_data && HeVAL(old_data)) {
 152                         SV* new_full_name = newSVpvn_flags(HvNAME(stash), HvNAMELEN_get(stash), HvNAMEUTF8(stash) ? SVf_UTF8 : 0);
 153                         sv_catpvn(new_full_name, "::", 2);
 154                         sv_catpvn_flags(new_full_name, nameptr, s - nameptr, utf8flag ? SV_CATUTF8 : SV_CATBYTES);
 155                         SvREFCNT_inc(HeVAL(old_data));
 156                         if (hv_store_ent(DBsub, new_full_name, HeVAL(old_data), 0) != NULL)
 157                                 SvREFCNT_inc(HeVAL(old_data));
 158                         SvREFCNT_dec(new_full_name);
 159                 }
 160         }
 161
 162         gv = (GV *) newSV(0);
 163         gv_init_pvn(gv, stash, nameptr, s - nameptr, GV_ADDMULTI | utf8flag);
 164
 165         mg = SvMAGIC(cv);
 166         while (mg && mg->mg_virtual != &subname_vtbl)
 167                 mg = mg->mg_moremagic;
 168         if (!mg) {
 169                 Newxz(mg, 1, MAGIC);
 170                 mg->mg_moremagic = SvMAGIC(cv);
 171                 mg->mg_type = PERL_MAGIC_ext;
 172                 mg->mg_virtual = &subname_vtbl;
 173                 SvMAGIC_set(cv, mg);
 174         }
 175         if (mg->mg_flags & MGf_REFCOUNTED)
 176                 SvREFCNT_dec(mg->mg_obj);
 177         mg->mg_flags |= MGf_REFCOUNTED;
 178         mg->mg_obj = (SV *) gv;
 179         SvRMAGICAL_on(cv);
 180         CvANON_off(cv);
 181 #ifndef CvGV_set
 182         CvGV(cv) = gv;
 183 #else
 184         CvGV_set(cv, gv);
 185 #endif
 186         PUSHs(sub);