Commit | Line | Data |
adfe19db |
1 | ################################################################################ |
2 | ## |
c1a049cb |
3 | ## $Revision: 13 $ |
adfe19db |
4 | ## $Author: mhx $ |
c1a049cb |
5 | ## $Date: 2008/01/04 10:47:43 +0100 $ |
adfe19db |
6 | ## |
7 | ################################################################################ |
8 | ## |
c1a049cb |
9 | ## Version 3.x, Copyright (C) 2004-2008, 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 | |
33 | void |
aab9a3b6 |
34 | newCONSTSUB(HV *stash, const char *name, SV *sv) |
adfe19db |
35 | { |
36 | U32 oldhints = PL_hints; |
37 | HV *old_cop_stash = PL_curcop->cop_stash; |
38 | HV *old_curstash = PL_curstash; |
39 | line_t oldline = PL_curcop->cop_line; |
40 | PL_curcop->cop_line = PL_copline; |
41 | |
42 | PL_hints &= ~HINT_BLOCK_SCOPE; |
43 | if (stash) |
44 | PL_curstash = PL_curcop->cop_stash = stash; |
45 | |
46 | newSUB( |
47 | |
48 | #if { VERSION < 5.003_22 } |
49 | start_subparse(), |
50 | #elif { VERSION == 5.003_22 } |
51 | start_subparse(0), |
52 | #else /* 5.003_23 onwards */ |
53 | start_subparse(FALSE, 0), |
54 | #endif |
55 | |
aab9a3b6 |
56 | newSVOP(OP_CONST, 0, newSVpv((char *) name, 0)), |
adfe19db |
57 | newSVOP(OP_CONST, 0, &PL_sv_no), /* SvPV(&PL_sv_no) == "" -- GMB */ |
58 | newSTATEOP(0, Nullch, newSVOP(OP_CONST, 0, sv)) |
59 | ); |
60 | |
61 | PL_hints = oldhints; |
62 | PL_curcop->cop_stash = old_cop_stash; |
63 | PL_curstash = old_curstash; |
64 | PL_curcop->cop_line = oldline; |
65 | } |
66 | #endif |
67 | #endif |
68 | |
69 | =xsinit |
70 | |
71 | #define NEED_newCONSTSUB |
72 | |
73 | =xsmisc |
74 | |
75 | void call_newCONSTSUB_1(void) |
76 | { |
77 | #ifdef PERL_NO_GET_CONTEXT |
78 | dTHX; |
79 | #endif |
80 | newCONSTSUB(gv_stashpv("Devel::PPPort", FALSE), "test_value_1", newSViv(1)); |
81 | } |
82 | |
83 | extern void call_newCONSTSUB_2(void); |
84 | extern void call_newCONSTSUB_3(void); |
85 | |
86 | =xsubs |
87 | |
88 | void |
89 | call_newCONSTSUB_1() |
90 | |
91 | void |
92 | call_newCONSTSUB_2() |
93 | |
94 | void |
95 | call_newCONSTSUB_3() |
96 | |
97 | =tests plan => 3 |
98 | |
4a582685 |
99 | &Devel::PPPort::call_newCONSTSUB_1(); |
adfe19db |
100 | ok(&Devel::PPPort::test_value_1(), 1); |
101 | |
4a582685 |
102 | &Devel::PPPort::call_newCONSTSUB_2(); |
adfe19db |
103 | ok(&Devel::PPPort::test_value_2(), 2); |
104 | |
4a582685 |
105 | &Devel::PPPort::call_newCONSTSUB_3(); |
adfe19db |
106 | ok(&Devel::PPPort::test_value_3(), 3); |
107 | |