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
  11 static MGVTBL subname_vtbl;
  12
  13 #ifndef PERL_MAGIC_ext
  14 # define PERL_MAGIC_ext '~'
  15 #endif
  16
  17 #ifndef SvMAGIC_set
  18 #define SvMAGIC_set(sv, val) (SvMAGIC(sv) = (val))
  19 #endif
  20
  21 #ifndef Newxz
  22 #define Newxz(ptr, num, type)   Newz(0, ptr, num, type)
  23 #endif
  24
  25 MODULE = Sub::Name  PACKAGE = Sub::Name
  26
  27 PROTOTYPES: DISABLE
  28
  29 void
  30 subname(name, sub)
  31         char *name
  32         SV *sub
  33     PREINIT:
  34         CV *cv = NULL;
  35         GV *gv;
  36         HV *stash = CopSTASH(PL_curcop);
  37         char *s, *end = NULL;
  38         MAGIC *mg;
  39     PPCODE:
  40         if (!SvROK(sub) && SvGMAGICAL(sub))
  41                 mg_get(sub);
  42         if (SvROK(sub))
  43                 cv = (CV *) SvRV(sub);
  44         else if (SvTYPE(sub) == SVt_PVGV)
  45                 cv = GvCVu(sub);
  46         else if (!SvOK(sub))
  47                 croak(PL_no_usym, "a subroutine");
  48         else if (PL_op->op_private & HINT_STRICT_REFS)
  49                 croak("Can't use string (\"%.32s\") as %s ref while \"strict refs\" in use",
  50                       SvPV_nolen(sub), "a subroutine");
  51         else if ((gv = gv_fetchpv(SvPV_nolen(sub), FALSE, SVt_PVCV)))
  52                 cv = GvCVu(gv);
  53         if (!cv)
  54                 croak("Undefined subroutine %s", SvPV_nolen(sub));
  55         if (SvTYPE(cv) != SVt_PVCV && SvTYPE(cv) != SVt_PVFM)
  56                 croak("Not a subroutine reference");
  57         for (s = name; *s++; ) {
  58                 if (*s == ':' && s[-1] == ':')
  59                         end = ++s;
  60                 else if (*s && s[-1] == '\'')
  61                         end = s;
  62         }
  63         s--;
  64         if (end) {
  65                 char *namepv = savepvn(name, end - name);
  66                 stash = GvHV(gv_fetchpv(namepv, TRUE, SVt_PVHV));
  67                 Safefree(namepv);
  68                 name = end;
  69         }
  70         gv = (GV *) newSV(0);
  71         gv_init(gv, stash, name, s - name, TRUE);
  72
  73         mg = SvMAGIC(cv);
  74         while (mg && mg->mg_virtual != &subname_vtbl)
  75                 mg = mg->mg_moremagic;
  76         if (!mg) {
  77                 Newxz(mg, 1, MAGIC);
  78                 mg->mg_moremagic = SvMAGIC(cv);
  79                 mg->mg_type = PERL_MAGIC_ext;
  80                 mg->mg_virtual = &subname_vtbl;
  81                 SvMAGIC_set(cv, mg);
  82         }
  83         if (mg->mg_flags & MGf_REFCOUNTED)
  84                 SvREFCNT_dec(mg->mg_obj);
  85         mg->mg_flags |= MGf_REFCOUNTED;
  86         mg->mg_obj = (SV *) gv;
  87         SvRMAGICAL_on(cv);
  88         CvANON_off(cv);
  89 #ifndef CvGV_set
  90         CvGV(cv) = gv;
  91 #else
  92         CvGV_set(cv, gv);
  93 #endif
  94         PUSHs(sub);