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