Name.xs

   1 /* $Id: Name.xs,v 1.5 2004/08/18 13:21:44 xmath Exp $
   2  * Copyright (C) 2004  Matthijs van Duin.  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 MODULE = Sub::Name  PACKAGE = Sub::Name
  14
  15 PROTOTYPES: DISABLE
  16
  17 void
  18 subname(name, sub)
  19         char *name
  20         SV *sub
  21     PREINIT:
  22         CV *cv = NULL;
  23         GV *gv;
  24         HV *stash = CopSTASH(PL_curcop);
  25         char *s, *end = NULL, saved;
  26     PPCODE:
  27         if (!SvROK(sub) && SvGMAGICAL(sub))
  28                 mg_get(sub);
  29         if (SvROK(sub))
  30                 cv = (CV *) SvRV(sub);
  31         else if (SvTYPE(sub) == SVt_PVGV)
  32                 cv = GvCVu(sub);
  33         else if (!SvOK(sub))
  34                 croak(PL_no_usym, "a subroutine");
  35         else if (PL_op->op_private & HINT_STRICT_REFS)
  36                 croak(PL_no_symref, SvPV_nolen(sub), "a subroutine");
  37         else if ((gv = gv_fetchpv(SvPV_nolen(sub), FALSE, SVt_PVCV)))
  38                 cv = GvCVu(gv);
  39         if (!cv)
  40                 croak("Undefined subroutine %s", SvPV_nolen(sub));
  41         if (SvTYPE(cv) != SVt_PVCV && SvTYPE(cv) != SVt_PVFM)
  42                 croak("Not a subroutine reference");
  43         for (s = name; *s++; ) {
  44                 if (*s == ':' && s[-1] == ':')
  45                         end = ++s;
  46                 else if (*s && s[-1] == '\'')
  47                         end = s;
  48         }
  49         s--;
  50         if (end) {
  51                 saved = *end;
  52                 *end = 0;
  53                 stash = GvHV(gv_fetchpv(name, TRUE, SVt_PVHV));
  54                 *end = saved;
  55                 name = end;
  56         }
  57         gv = (GV *) newSV(0);
  58         gv_init(gv, stash, name, s - name, TRUE);
  59 #ifndef USE_5005THREADS
  60         if (CvPADLIST(cv)) {
  61                 /* cheap way to refcount the gv */
  62                 av_store((AV *) AvARRAY(CvPADLIST(cv))[0], 0, (SV *) gv);
  63         }
  64 #endif
  65         else {
  66                 /* expensive way to refcount the gv */
  67                 MAGIC *mg = SvMAGIC(cv);
  68                 while (mg && mg->mg_virtual != &subname_vtbl)
  69                         mg = mg->mg_moremagic;
  70                 if (!mg)
  71                         mg = sv_magicext((SV *) cv, NULL, PERL_MAGIC_ext,
  72                                         &subname_vtbl, NULL, 0);
  73                 if (mg->mg_flags & MGf_REFCOUNTED)
  74                         SvREFCNT_dec(mg->mg_obj);
  75                 mg->mg_flags |= MGf_REFCOUNTED;
  76                 mg->mg_obj = (SV *) gv;
  77         }
  78         CvGV(cv) = gv;
  79         PUSHs(sub);