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         int utf8flag = SvUTF8(name);
  44         const char* nameptr = SvPV(name, namelen);
  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 == ':' && s[-1] == ':') {
  67                         end = s - 1;
  68                         begin = ++s;
  69                         if (seen_quote)
  70                                 seen_quote++;
  71                 }
  72                 else if (*s && s[-1] == '\'') {
  73                         end = s - 1;
  74                         begin = s;
  75                         seen_quote++;
  76                 }
  77         }
  78         s--;
  79         if (end) {
  80                 SV* tmp;
  81                 if (seen_quote > 1) {
  82                         STRLEN length = end - nameptr + seen_quote;
  83                         char* left;
  84                         int i, j;
  85                         tmp = newSV(length);
  86                         left = SvPVX(tmp);
  87                         for (i = 0, j = 0; j <= end - nameptr; ++i, ++j) {
  88                                 if (nameptr[j] == '\'') {
  89                                         left[i] = ':';
  90                                         left[++i] = ':';
  91                                 }
  92                                 else {
  93                                         left[i] = nameptr[j];
  94                                 }
  95                         }
  96                         stash = gv_stashpvn(left, i - 2, GV_ADD | utf8flag);
  97                         SvREFCNT_dec(tmp);
  98                 }
  99                 else
 100                         stash = gv_stashpvn(nameptr, end - nameptr, GV_ADD | utf8flag);
 101                 nameptr = begin;
 102                 namelen -= begin - nameptr;
 103         }
 104
 105         #ifdef PERL_VERSION < 10
 106         /* under debugger, provide information about sub location */
 107         if (PL_DBsub && CvGV(cv)) {
 108                 HV *hv = GvHV(PL_DBsub);
 109                 SV** old_data;
 110
 111                 char* new_pkg = HvNAME(stash);
 112
 113                 char* old_name = GvNAME( CvGV(cv) );
 114                 char* old_pkg = HvNAME( GvSTASH(CvGV(cv)) );
 115
 116                 int old_len = strlen(old_name) + strlen(old_pkg);
 117                 int new_len = namelen + strlen(new_pkg);
 118
 119                 char* full_name;
 120                 Newxz(full_name, (old_len > new_len ? old_len : new_len) + 3, char);
 121
 122                 strcat(full_name, old_pkg);
 123                 strcat(full_name, "::");
 124                 strcat(full_name, old_name);
 125
 126                 old_data = hv_fetch(hv, full_name, strlen(full_name), 0);
 127
 128                 if (old_data) {
 129                         strcpy(full_name, new_pkg);
 130                         strcat(full_name, "::");
 131                         strcat(full_name, nameptr);
 132
 133                         SvREFCNT_inc(*old_data);
 134                         if (!hv_store(hv, full_name, strlen(full_name), *old_data, 0))
 135                                 SvREFCNT_dec(*old_data);
 136                 }
 137                 Safefree(full_name);
 138         }
 139         #endif
 140
 141         gv = (GV *) newSV(0);
 142         gv_init_pvn(gv, stash, nameptr, s - nameptr, GV_ADDMULTI | utf8flag);
 143
 144         mg = SvMAGIC(cv);
 145         while (mg && mg->mg_virtual != &subname_vtbl)
 146                 mg = mg->mg_moremagic;
 147         if (!mg) {
 148                 Newxz(mg, 1, MAGIC);
 149                 mg->mg_moremagic = SvMAGIC(cv);
 150                 mg->mg_type = PERL_MAGIC_ext;
 151                 mg->mg_virtual = &subname_vtbl;
 152                 SvMAGIC_set(cv, mg);
 153         }
 154         if (mg->mg_flags & MGf_REFCOUNTED)
 155                 SvREFCNT_dec(mg->mg_obj);
 156         mg->mg_flags |= MGf_REFCOUNTED;
 157         mg->mg_obj = (SV *) gv;
 158         SvRMAGICAL_on(cv);
 159         CvANON_off(cv);
 160 #ifndef CvGV_set
 161         CvGV(cv) = gv;
 162 #else
 163         CvGV_set(cv, gv);
 164 #endif
 165         PUSHs(sub);