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         /* under debugger, provide information about sub location */
  78         if (PL_DBsub && CvGV(cv)) {
  79                 HV *hv = GvHV(PL_DBsub);
  80                 SV** old_data;
  81
  82                 char* new_pkg = HvNAME(stash);
  83
  84                 char* old_name = GvNAME( CvGV(cv) );
  85                 char* old_pkg = HvNAME( GvSTASH(CvGV(cv)) );
  86
  87                 int old_len = strlen(old_name) + strlen(old_pkg);
  88                 int new_len = namelen + strlen(new_pkg);
  89
  90                 char* full_name;
  91                 Newxz(full_name, (old_len > new_len ? old_len : new_len) + 3, char);
  92
  93                 strcat(full_name, old_pkg);
  94                 strcat(full_name, "::");
  95                 strcat(full_name, old_name);
  96
  97                 old_data = hv_fetch(hv, full_name, strlen(full_name), 0);
  98
  99                 if (old_data) {
 100                         strcpy(full_name, new_pkg);
 101                         strcat(full_name, "::");
 102                         strcat(full_name, nameptr);
 103
 104                         SvREFCNT_inc(*old_data);
 105                         if (!hv_store(hv, full_name, strlen(full_name), *old_data, 0))
 106                                 SvREFCNT_dec(*old_data);
 107                 }
 108                 Safefree(full_name);
 109         }
 110
 111         gv = (GV *) newSV(0);
 112         gv_init_pvn(gv, stash, nameptr, s - nameptr, GV_ADDMULTI | utf8flag);
 113
 114         mg = SvMAGIC(cv);
 115         while (mg && mg->mg_virtual != &subname_vtbl)
 116                 mg = mg->mg_moremagic;
 117         if (!mg) {
 118                 Newxz(mg, 1, MAGIC);
 119                 mg->mg_moremagic = SvMAGIC(cv);
 120                 mg->mg_type = PERL_MAGIC_ext;
 121                 mg->mg_virtual = &subname_vtbl;
 122                 SvMAGIC_set(cv, mg);
 123         }
 124         if (mg->mg_flags & MGf_REFCOUNTED)
 125                 SvREFCNT_dec(mg->mg_obj);
 126         mg->mg_flags |= MGf_REFCOUNTED;
 127         mg->mg_obj = (SV *) gv;
 128         SvRMAGICAL_on(cv);
 129         CvANON_off(cv);
 130 #ifndef CvGV_set
 131         CvGV(cv) = gv;
 132 #else
 133         CvGV_set(cv, gv);
 134 #endif
 135         PUSHs(sub);