Name.xs

   1 /* Copyright (C) 2004, 2008  Matthijs van Duin.  All rights reserved.
   2  * This program is free software; you can redistribute it and/or modify
   3  * it under the same terms as Perl itself.
   4  */
   5
   6 #include "EXTERN.h"
   7 #include "perl.h"
   8 #include "XSUB.h"
   9
  10 static MGVTBL subname_vtbl;
  11
  12 #ifndef PERL_MAGIC_ext
  13 # define PERL_MAGIC_ext '~'
  14 #endif
  15
  16 #ifndef SvMAGIC_set
  17 #define SvMAGIC_set(sv, val) (SvMAGIC(sv) = (val))
  18 #endif
  19
  20
  21 MODULE = Sub::Name  PACKAGE = Sub::Name
  22
  23 PROTOTYPES: DISABLE
  24
  25 void
  26 subname(name, sub)
  27         char *name
  28         SV *sub
  29     PREINIT:
  30         CV *cv = NULL;
  31         GV *gv;
  32         HV *stash = CopSTASH(PL_curcop);
  33         char *s, *end = NULL, saved;
  34     PPCODE:
  35         if (!SvROK(sub) && SvGMAGICAL(sub))
  36                 mg_get(sub);
  37         if (SvROK(sub))
  38                 cv = (CV *) SvRV(sub);
  39         else if (SvTYPE(sub) == SVt_PVGV)
  40                 cv = GvCVu(sub);
  41         else if (!SvOK(sub))
  42                 croak(PL_no_usym, "a subroutine");
  43         else if (PL_op->op_private & HINT_STRICT_REFS)
  44                 croak("Can't use string (\"%.32s\") as %s ref while \"strict refs\" in use",
  45                       SvPV_nolen(sub), "a subroutine");
  46         else if ((gv = gv_fetchpv(SvPV_nolen(sub), FALSE, SVt_PVCV)))
  47                 cv = GvCVu(gv);
  48         if (!cv)
  49                 croak("Undefined subroutine %s", SvPV_nolen(sub));
  50         if (SvTYPE(cv) != SVt_PVCV && SvTYPE(cv) != SVt_PVFM)
  51                 croak("Not a subroutine reference");
  52         for (s = name; *s++; ) {
  53                 if (*s == ':' && s[-1] == ':')
  54                         end = ++s;
  55                 else if (*s && s[-1] == '\'')
  56                         end = s;
  57         }
  58         s--;
  59         if (end) {
  60                 saved = *end;
  61                 *end = 0;
  62                 stash = GvHV(gv_fetchpv(name, TRUE, SVt_PVHV));
  63                 *end = saved;
  64                 name = end;
  65         }
  66         gv = (GV *) newSV(0);
  67         gv_init(gv, stash, name, s - name, TRUE);
  68 #ifndef USE_5005THREADS
  69         if (CvPADLIST(cv)) {
  70                 /* cheap way to refcount the gv */
  71                 av_store((AV *) AvARRAY(CvPADLIST(cv))[0], 0, (SV *) gv);
  72         } else
  73 #endif
  74         {
  75                 /* expensive way to refcount the gv */
  76                 MAGIC *mg = SvMAGIC(cv);
  77                 while (mg && mg->mg_virtual != &subname_vtbl)
  78                         mg = mg->mg_moremagic;
  79                 if (!mg) {
  80                         Newz(702, mg, 1, MAGIC);
  81                         mg->mg_moremagic = SvMAGIC(cv);
  82                         mg->mg_type = PERL_MAGIC_ext;
  83                         mg->mg_virtual = &subname_vtbl;
  84                         SvMAGIC_set(cv, mg);
  85                 }
  86                 if (mg->mg_flags & MGf_REFCOUNTED)
  87                         SvREFCNT_dec(mg->mg_obj);
  88                 mg->mg_flags |= MGf_REFCOUNTED;
  89                 mg->mg_obj = (SV *) gv;
  90         }
  91         CvGV(cv) = gv;
  92         PUSHs(sub);