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;
  41         MAGIC *mg;
  42         STRLEN namelen;
  43         int utf8flag = SvUTF8(name);
  44         const char* nameptr = SvPV(name, namelen);
  45     PPCODE:
  46         if (!SvROK(sub) && SvGMAGICAL(sub))
  47                 mg_get(sub);
  48         if (SvROK(sub))
  49                 cv = (CV *) SvRV(sub);
  50         else if (SvTYPE(sub) == SVt_PVGV)
  51                 cv = GvCVu(sub);
  52         else if (!SvOK(sub))
  53                 croak(PL_no_usym, "a subroutine");
  54         else if (PL_op->op_private & HINT_STRICT_REFS)
  55                 croak("Can't use string (\"%.32s\") as %s ref while \"strict refs\" in use",
  56                       SvPV_nolen(sub), "a subroutine");
  57         else if ((gv = gv_fetchsv(sub, FALSE, SVt_PVCV)))
  58                 cv = GvCVu(gv);
  59         if (!cv)
  60                 croak("Undefined subroutine %s", SvPV_nolen(sub));
  61         if (SvTYPE(cv) != SVt_PVCV && SvTYPE(cv) != SVt_PVFM)
  62                 croak("Not a subroutine reference");
  63
  64         for (s = nameptr; s <= nameptr + namelen; s++) {
  65                 if (*s == ':' && s[-1] == ':')
  66                         end = ++s;
  67                 else if (*s && s[-1] == '\'')
  68                         end = s;
  69         }
  70         s--;
  71         if (end) {
  72                 stash = GvHV(gv_fetchpvn_flags(nameptr, end - nameptr, GV_ADD | utf8flag, SVt_PVHV));
  73                 nameptr = end;
  74                 namelen -= end - nameptr;
  75         }
  76
  77         #ifdef PERL_VERSION < 10
  78         /* under debugger, provide information about sub location */
  79         if (PL_DBsub && CvGV(cv)) {
  80                 HV *hv = GvHV(PL_DBsub);
  81                 SV** old_data;
  82
  83                 char* new_pkg = HvNAME(stash);
  84
  85                 char* old_name = GvNAME( CvGV(cv) );
  86                 char* old_pkg = HvNAME( GvSTASH(CvGV(cv)) );
  87
  88                 int old_len = strlen(old_name) + strlen(old_pkg);
  89                 int new_len = namelen + strlen(new_pkg);
  90
  91                 char* full_name;
  92                 Newxz(full_name, (old_len > new_len ? old_len : new_len) + 3, char);
  93
  94                 strcat(full_name, old_pkg);
  95                 strcat(full_name, "::");
  96                 strcat(full_name, old_name);
  97
  98                 old_data = hv_fetch(hv, full_name, strlen(full_name), 0);
  99
 100                 if (old_data) {
 101                         strcpy(full_name, new_pkg);
 102                         strcat(full_name, "::");
 103                         strcat(full_name, nameptr);
 104
 105                         SvREFCNT_inc(*old_data);
 106                         if (!hv_store(hv, full_name, strlen(full_name), *old_data, 0))
 107                                 SvREFCNT_dec(*old_data);
 108                 }
 109                 Safefree(full_name);
 110         }
 111         #endif
 112
 113         gv = (GV *) newSV(0);
 114         gv_init_pvn(gv, stash, nameptr, s - nameptr, GV_ADDMULTI | utf8flag);
 115
 116         mg = SvMAGIC(cv);
 117         while (mg && mg->mg_virtual != &subname_vtbl)
 118                 mg = mg->mg_moremagic;
 119         if (!mg) {
 120                 Newxz(mg, 1, MAGIC);
 121                 mg->mg_moremagic = SvMAGIC(cv);
 122                 mg->mg_type = PERL_MAGIC_ext;
 123                 mg->mg_virtual = &subname_vtbl;
 124                 SvMAGIC_set(cv, mg);
 125         }
 126         if (mg->mg_flags & MGf_REFCOUNTED)
 127                 SvREFCNT_dec(mg->mg_obj);
 128         mg->mg_flags |= MGf_REFCOUNTED;
 129         mg->mg_obj = (SV *) gv;
 130         SvRMAGICAL_on(cv);
 131         CvANON_off(cv);
 132 #ifndef CvGV_set
 133         CvGV(cv) = gv;
 134 #else
 135         CvGV_set(cv, gv);
 136 #endif
 137         PUSHs(sub);