1################################################################################
2##
3##  Version 3.x, Copyright (C) 2004-2013, Marcus Holland-Moritz.
4##  Version 2.x, Copyright (C) 2001, Paul Marquess.
5##  Version 1.x, Copyright (C) 1999, Kenneth Albanowski.
6##
7##  This program is free software; you can redistribute it and/or
8##  modify it under the same terms as Perl itself.
9##
10################################################################################
11
12=provides
13
14newCONSTSUB
15
16=dontwarn
17
18NEED_newCONSTSUB    /* Because we define this weirdly */
19
20=implementation
21
22/* newCONSTSUB from IO.xs is in the core starting with 5.004_63 */
23#if { VERSION < 5.004_63 } && { VERSION != 5.004_05 }
24
25/* And before that, we need to make sure this gets compiled for the functions
26 * that rely on it */
27#define NEED_newCONSTSUB
28
29#if { NEED newCONSTSUB }
30
31/* This is just a trick to avoid a dependency of newCONSTSUB on PL_parser */
32/* (There's no PL_parser in perl < 5.005, so this is completely safe)     */
33#define D_PPP_PL_copline PL_copline
34
35CV *
36newCONSTSUB(HV *stash, const char *name, SV *sv)
37{
38        CV *cv;
39        U32 oldhints = PL_hints;
40        HV *old_cop_stash = PL_curcop->cop_stash;
41        HV *old_curstash = PL_curstash;
42        line_t oldline = PL_curcop->cop_line;
43        PL_curcop->cop_line = D_PPP_PL_copline;
44
45        PL_hints &= ~HINT_BLOCK_SCOPE;
46        if (stash)
47                PL_curstash = PL_curcop->cop_stash = stash;
48
49        cv = newSUB(
50
51                start_subparse(FALSE, 0),
52
53                newSVOP(OP_CONST, 0, newSVpv((char *) name, 0)),
54                newSVOP(OP_CONST, 0, &PL_sv_no),   /* SvPV(&PL_sv_no) == "" -- GMB */
55                newSTATEOP(0, Nullch, newSVOP(OP_CONST, 0, sv))
56        );
57
58        PL_hints = oldhints;
59        PL_curcop->cop_stash = old_cop_stash;
60        PL_curstash = old_curstash;
61        PL_curcop->cop_line = oldline;
62
63        return cv;
64}
65#endif
66#endif
67
68=xsinit
69
70#define NEED_newCONSTSUB
71
72=xsmisc
73
74void call_newCONSTSUB_1(void)
75{
76#ifdef PERL_NO_GET_CONTEXT
77        dTHX;
78#endif
79        newCONSTSUB(gv_stashpv("Devel::PPPort", FALSE), "test_value_1", newSViv(1));
80}
81
82extern void call_newCONSTSUB_2(void);
83extern void call_newCONSTSUB_3(void);
84
85=xsubs
86
87void
88call_newCONSTSUB_1()
89
90void
91call_newCONSTSUB_2()
92
93void
94call_newCONSTSUB_3()
95
96=tests plan => 3
97
98&Devel::PPPort::call_newCONSTSUB_1();
99is(&Devel::PPPort::test_value_1(), 1);
100
101&Devel::PPPort::call_newCONSTSUB_2();
102is(&Devel::PPPort::test_value_2(), 2);
103
104&Devel::PPPort::call_newCONSTSUB_3();
105is(&Devel::PPPort::test_value_3(), 3);
106