Commit | Line | Data |
---|---|---|
adfe19db MHM |
1 | ################################################################################ |
2 | ## | |
b2049988 | 3 | ## Version 3.x, Copyright (C) 2004-2013, Marcus Holland-Moritz. |
adfe19db MHM |
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 | ||
14 | newCONSTSUB | |
15 | ||
59be6e16 KW |
16 | =dontwarn |
17 | ||
18 | NEED_newCONSTSUB /* Because we define this weirdly */ | |
19 | ||
adfe19db MHM |
20 | =implementation |
21 | ||
adfe19db MHM |
22 | /* newCONSTSUB from IO.xs is in the core starting with 5.004_63 */ |
23 | #if { VERSION < 5.004_63 } && { VERSION != 5.004_05 } | |
59be6e16 KW |
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 | ||
adfe19db MHM |
29 | #if { NEED newCONSTSUB } |
30 | ||
c01be2ce MHM |
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 | ||
46677718 | 35 | CV * |
aab9a3b6 | 36 | newCONSTSUB(HV *stash, const char *name, SV *sv) |
adfe19db | 37 | { |
46677718 | 38 | CV *cv; |
b2049988 MHM |
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; | |
adfe19db | 44 | |
b2049988 MHM |
45 | PL_hints &= ~HINT_BLOCK_SCOPE; |
46 | if (stash) | |
47 | PL_curstash = PL_curcop->cop_stash = stash; | |
adfe19db | 48 | |
46677718 | 49 | cv = newSUB( |
adfe19db | 50 | |
b2049988 | 51 | start_subparse(FALSE, 0), |
adfe19db | 52 | |
b2049988 MHM |
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 | ); | |
adfe19db | 57 | |
b2049988 MHM |
58 | PL_hints = oldhints; |
59 | PL_curcop->cop_stash = old_cop_stash; | |
60 | PL_curstash = old_curstash; | |
61 | PL_curcop->cop_line = oldline; | |
46677718 N |
62 | |
63 | return cv; | |
adfe19db MHM |
64 | } |
65 | #endif | |
66 | #endif | |
67 | ||
68 | =xsinit | |
69 | ||
70 | #define NEED_newCONSTSUB | |
71 | ||
72 | =xsmisc | |
73 | ||
74 | void call_newCONSTSUB_1(void) | |
75 | { | |
76 | #ifdef PERL_NO_GET_CONTEXT | |
b2049988 | 77 | dTHX; |
adfe19db | 78 | #endif |
b2049988 | 79 | newCONSTSUB(gv_stashpv("Devel::PPPort", FALSE), "test_value_1", newSViv(1)); |
adfe19db MHM |
80 | } |
81 | ||
82 | extern void call_newCONSTSUB_2(void); | |
83 | extern void call_newCONSTSUB_3(void); | |
84 | ||
85 | =xsubs | |
86 | ||
87 | void | |
88 | call_newCONSTSUB_1() | |
89 | ||
90 | void | |
91 | call_newCONSTSUB_2() | |
92 | ||
93 | void | |
94 | call_newCONSTSUB_3() | |
95 | ||
96 | =tests plan => 3 | |
97 | ||
4a582685 | 98 | &Devel::PPPort::call_newCONSTSUB_1(); |
8154c0b1 | 99 | is(&Devel::PPPort::test_value_1(), 1); |
adfe19db | 100 | |
4a582685 | 101 | &Devel::PPPort::call_newCONSTSUB_2(); |
8154c0b1 | 102 | is(&Devel::PPPort::test_value_2(), 2); |
adfe19db | 103 | |
4a582685 | 104 | &Devel::PPPort::call_newCONSTSUB_3(); |
8154c0b1 | 105 | is(&Devel::PPPort::test_value_3(), 3); |