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_gv_fetchpvn_flags
  12 #include "ppport.h"
  13
  14 static MGVTBL subname_vtbl;
  15
  16 #ifndef PERL_MAGIC_ext
  17 # define PERL_MAGIC_ext '~'
  18 #endif
  19
  20 #ifndef SvMAGIC_set
  21 #define SvMAGIC_set(sv, val) (SvMAGIC(sv) = (val))
  22 #endif
  23
  24 #ifndef Newxz
  25 #define Newxz(ptr, num, type)   Newz(0, ptr, num, type)
  26 #endif
  27
  28 MODULE = Sub::Name  PACKAGE = Sub::Name
  29
  30 PROTOTYPES: DISABLE
  31
  32 void
  33 subname(name, sub)
  34         SV *name
  35         SV *sub
  36     PREINIT:
  37         CV *cv = NULL;
  38         GV *gv;
  39         HV *stash = CopSTASH(PL_curcop);
  40         const char *s, *end = NULL, *begin = NULL;
  41         MAGIC *mg;
  42         STRLEN namelen;
  43         const char* nameptr = SvPV(name, namelen);
  44         int utf8flag = SvUTF8(name);
  45         int seen_quote = 0, need_subst = 0;
  46     PPCODE:
  47         if (!SvROK(sub) && SvGMAGICAL(sub))
  48                 mg_get(sub);
  49         if (SvROK(sub))
  50                 cv = (CV *) SvRV(sub);
  51         else if (SvTYPE(sub) == SVt_PVGV)
  52                 cv = GvCVu(sub);
  53         else if (!SvOK(sub))
  54                 croak(PL_no_usym, "a subroutine");
  55         else if (PL_op->op_private & HINT_STRICT_REFS)
  56                 croak("Can't use string (\"%.32s\") as %s ref while \"strict refs\" in use",
  57                       SvPV_nolen(sub), "a subroutine");
  58         else if ((gv = gv_fetchsv(sub, FALSE, SVt_PVCV)))
  59                 cv = GvCVu(gv);
  60         if (!cv)
  61                 croak("Undefined subroutine %s", SvPV_nolen(sub));
  62         if (SvTYPE(cv) != SVt_PVCV && SvTYPE(cv) != SVt_PVFM)
  63                 croak("Not a subroutine reference");
  64
  65         for (s = nameptr; s <= nameptr + namelen; s++) {
  66                 if (s > nameptr && *s == ':' && s[-1] == ':') {
  67                         end = s - 1;
  68                         begin = ++s;
  69                         if (seen_quote)
  70                                 need_subst++;
  71                 }
  72                 else if (s > nameptr && *s != '\0' && s[-1] == '\'') {
  73                         end = s - 1;
  74                         begin = s;
  75                         if (seen_quote++)
  76                                 need_subst++;
  77                 }
  78         }
  79         s--;
  80         if (end) {
  81                 SV* tmp;
  82                 if (need_subst) {
  83                         STRLEN length = end - nameptr + seen_quote - (*end == '\'' ? 1 : 0);
  84                         char* left;
  85                         int i, j;
  86                         tmp = newSV(length);
  87                         left = SvPVX(tmp);
  88                         for (i = 0, j = 0; j < end - nameptr; ++i, ++j) {
  89                                 if (nameptr[j] == '\'') {
  90                                         left[i] = ':';
  91                                         left[++i] = ':';
  92                                 }
  93                                 else {
  94                                         left[i] = nameptr[j];
  95                                 }
  96                         }
  97                         stash = gv_stashpvn(left, length, GV_ADD | utf8flag);
  98                         SvREFCNT_dec(tmp);
  99                 }
 100                 else
 101                         stash = gv_stashpvn(nameptr, end - nameptr, GV_ADD | utf8flag);
 102                 nameptr = begin;
 103                 namelen -= begin - nameptr;
 104         }
 105
 106         #ifdef PERL_VERSION < 10
 107         /* under debugger, provide information about sub location */
 108         if (PL_DBsub && CvGV(cv)) {
 109                 HV *hv = GvHV(PL_DBsub);
 110                 SV** old_data;
 111
 112                 char* new_pkg = HvNAME(stash);
 113
 114                 char* old_name = GvNAME( CvGV(cv) );
 115                 char* old_pkg = HvNAME( GvSTASH(CvGV(cv)) );
 116
 117                 int old_len = strlen(old_name) + strlen(old_pkg);
 118                 int new_len = namelen + strlen(new_pkg);
 119
 120                 char* full_name;
 121                 Newxz(full_name, (old_len > new_len ? old_len : new_len) + 3, char);
 122
 123                 strcat(full_name, old_pkg);
 124                 strcat(full_name, "::");
 125                 strcat(full_name, old_name);
 126
 127                 old_data = hv_fetch(hv, full_name, strlen(full_name), 0);
 128
 129                 if (old_data) {
 130                         strcpy(full_name, new_pkg);
 131                         strcat(full_name, "::");
 132                         strcat(full_name, nameptr);
 133
 134                         SvREFCNT_inc(*old_data);
 135                         if (!hv_store(hv, full_name, strlen(full_name), *old_data, 0))
 136                                 SvREFCNT_dec(*old_data);
 137                 }
 138                 Safefree(full_name);
 139         }
 140         #endif
 141
 142         gv = (GV *) newSV(0);
 143         gv_init_pvn(gv, stash, nameptr, s - nameptr, GV_ADDMULTI | utf8flag);
 144
 145         mg = SvMAGIC(cv);
 146         while (mg && mg->mg_virtual != &subname_vtbl)
 147                 mg = mg->mg_moremagic;
 148         if (!mg) {
 149                 Newxz(mg, 1, MAGIC);
 150                 mg->mg_moremagic = SvMAGIC(cv);
 151                 mg->mg_type = PERL_MAGIC_ext;
 152                 mg->mg_virtual = &subname_vtbl;
 153                 SvMAGIC_set(cv, mg);
 154         }
 155         if (mg->mg_flags & MGf_REFCOUNTED)
 156                 SvREFCNT_dec(mg->mg_obj);
 157         mg->mg_flags |= MGf_REFCOUNTED;
 158         mg->mg_obj = (SV *) gv;
 159         SvRMAGICAL_on(cv);
 160         CvANON_off(cv);
 161 #ifndef CvGV_set
 162         CvGV(cv) = gv;
 163 #else
 164         CvGV_set(cv, gv);
 165 #endif
 166         PUSHs(sub);