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