FLORA / Sub-Name-0.05 / Name.xs 

            

              
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91

              
/* Copyright (C) 2004, 2008  Matthijs van Duin.  All rights reserved.
 * This program is free software; you can redistribute it and/or modify
 * it under the same terms as Perl itself.
 */
#include "EXTERN.h"
#include "perl.h"
#include "XSUB.h"
static MGVTBL subname_vtbl;
#ifndef PERL_MAGIC_ext
# define PERL_MAGIC_ext '~'
#endif
#ifndef SvMAGIC_set
#define SvMAGIC_set(sv, val) (SvMAGIC(sv) = (val))
#endif
MODULE = Sub::Name  PACKAGE = Sub::Name
PROTOTYPES: DISABLE
void
subname(name, sub)
        char *name
        SV *sub
    PREINIT:
        CV *cv = NULL;
        GV *gv;
        HV *stash = CopSTASH(PL_curcop);
        char *s, *end = NULL, saved;
        MAGIC *mg;
    PPCODE:
        if (!SvROK(sub) && SvGMAGICAL(sub))
                mg_get(sub);
        if (SvROK(sub))
                cv = (CV *) SvRV(sub);
        else if (SvTYPE(sub) == SVt_PVGV)
                cv = GvCVu(sub);
        else if (!SvOK(sub))
                croak(PL_no_usym, "a subroutine");
        else if (PL_op->op_private & HINT_STRICT_REFS)
                croak("Can't use string (\"%.32s\") as %s ref while \"strict refs\" in use",
                      SvPV_nolen(sub), "a subroutine");
        else if ((gv = gv_fetchpv(SvPV_nolen(sub), FALSE, SVt_PVCV)))
                cv = GvCVu(gv);
        if (!cv)
                croak("Undefined subroutine %s", SvPV_nolen(sub));
        if (SvTYPE(cv) != SVt_PVCV && SvTYPE(cv) != SVt_PVFM)
                croak("Not a subroutine reference");
        for (s = name; *s++; ) {
                if (*s == ':' && s[-1] == ':')
                        end = ++s;
                else if (*s && s[-1] == '\'')
                        end = s;
        }
        s--;
        if (end) {
                saved = *end;
                *end = 0;
                stash = GvHV(gv_fetchpv(name, TRUE, SVt_PVHV));
                *end = saved;
                name = end;
        }
        gv = (GV *) newSV(0);
        gv_init(gv, stash, name, s - name, TRUE);
        mg = SvMAGIC(cv);
        while (mg && mg->mg_virtual != &subname_vtbl)
                mg = mg->mg_moremagic;
        if (!mg) {
                Newz(702, mg, 1, MAGIC);
                mg->mg_moremagic = SvMAGIC(cv);
                mg->mg_type = PERL_MAGIC_ext;
                mg->mg_virtual = &subname_vtbl;
                SvMAGIC_set(cv, mg);
        }
        if (mg->mg_flags & MGf_REFCOUNTED)
                SvREFCNT_dec(mg->mg_obj);
        mg->mg_flags |= MGf_REFCOUNTED;
        mg->mg_obj = (SV *) gv;
        SvRMAGICAL_on(cv);
        CvANON_off(cv);
#ifndef CvGV_set
        CvGV(cv) = gv;
#else
        CvGV_set(cv, gv);
#endif
        PUSHs(sub);