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 #ifdef USE_5005THREADS
  12 #error "Not compatible with 5.005 threads"
  13 #endif
  14
  15 MODULE = Sub::Name  PACKAGE = Sub::Name
  16
  17 PROTOTYPES: DISABLE
  18
  19 void
  20 subname(name, sub)
  21         char *name
  22         SV *sub
  23     PREINIT:
  24         CV *cv = NULL;
  25         GV *gv;
  26         HV *stash = CopSTASH(PL_curcop);
  27         char *s, *end = NULL, saved;
  28     PPCODE:
  29         if (!SvROK(sub) && SvGMAGICAL(sub))
  30                 mg_get(sub);
  31         if (SvROK(sub))
  32                 cv = (CV *) SvRV(sub);
  33         else if (SvTYPE(sub) == SVt_PVGV)
  34                 cv = GvCVu(sub);
  35         else if (!SvOK(sub))
  36                 croak(PL_no_usym, "a subroutine");
  37         else if (PL_op->op_private & HINT_STRICT_REFS)
  38                 croak(PL_no_symref, SvPV_nolen(sub), "a subroutine");
  39         else if ((gv = gv_fetchpv(SvPV_nolen(sub), FALSE, SVt_PVCV)))
  40                 cv = GvCVu(gv);
  41         if (!cv)
  42                 croak("Undefined subroutine %s", SvPV_nolen(sub));
  43         if (SvTYPE(cv) != SVt_PVCV && SvTYPE(cv) != SVt_PVFM)
  44                 croak("Not a subroutine reference");
  45         for (s = name; *s++; ) {
  46                 if (*s == ':' && s[-1] == ':')
  47                         end = ++s;
  48                 else if (*s && s[-1] == '\'')
  49                         end = s;
  50         }
  51         s--;
  52         if (end) {
  53                 saved = *end;
  54                 *end = 0;
  55                 stash = GvHV(gv_fetchpv(name, TRUE, SVt_PVHV));
  56                 *end = saved;
  57                 name = end;
  58         }
  59         gv = (GV *) newSV(0);
  60         gv_init(gv, stash, name, s - name, TRUE);
  61         av_store((AV *) AvARRAY(CvPADLIST(cv))[0], 0, (SV *) gv);
  62         CvGV(cv) = gv;
  63         PUSHs(sub);